perm filename LEPRUN[S,AIL]15 blob
sn#033794 filedate 1973-04-05 generic text, type T, neo UTF8
COMMENT ⊗ VALID 00042 PAGES VERSION 16-2(53)
RECORD PAGE DESCRIPTION
00001 00001
00009 00002 HISTORY
00015 00003 Leaping runtime routines. Sept. 1972.
00022 00004 DSCR FOREACH INTERPRETATION EXAMPLE
00028 00005 DSCR LEAP ALLOCATION -- START OF PROGRAM.
00032 00006 NOLOW <
00040 00007 DSCR INTERLOCKS FOR LEAP GLOBAL MODEL
00046 00008 DSCR MAIN DISPATCHER FOR LEAP
00049 00009 DISPATCH TABLE FOR THE LEAP INTERPRETER.
00055 00010 DSCR ASSOCIATIVE SEARCH ROUTINES
00057 00011 THE SEARCH ROUTINES.....
00062 00012 XO≡V
00070 00013 X ε S
00072 00014 DSCR FORSET AND NOFOR -- MAKE A SEARCH CONTROL BLOCK
00078 00015 DSCR FOREACH STATEMENT INTERPRETER
00093 00016 DSCR ? LOCAL STACK ROUTINES,STK4LC,STK4VL
00095 00017 DSCR BNDTRP- BINDING FORM OF BOOLEAN AOO≡V
00099 00018 SOME VARIOUS BOOLEANS
00101 00019 DSCR DERIVED SETS -- NOT IN FOREACH SPECIFICATIONS.
00104 00020 DSCR MAKE AND ERASE
00113 00021 PUSHJ, TO ERASE
00116 00022 SKIPA
00119 00023 LEAP BREAKPOINTS EXIST.
00122 00024 DSCR ISTRIPLE, SELECTOR
00124 00025 DSCR DELETE, NEW (VARIOUS KINDS), AND ARRAY ITEM CODE.
00131 00026 ↑ARRCLR:
00132 00027 NEW: GET A NEW ITEM NUMBER.
00143 00028 DSCR SET AND ITEM STORING OPERATIONS.
00150 00029 DSCR SET OPERATIONS
00156 00030 DSCR MORE SET OPERATIONS
00160 00031
00163 00032 DSCR UNION, INTERSECTION, SUBTRACTION
00170 00033 DSCR PUTAFTER,PUTBEFORE
00176 00034 DSCR SET RECLAMATION ROUTINES.
00181 00035 DSCR RPLAC
00183 00036 DSCR TYPEX-to determine the type of an item
00186 00037 DSCR TYPEIT -same as TYPEX except does not return datum address in left
00190 00038 DSCR PUTXA,PUTXB
00194 00039 DSCR INTNAM,CVSI,CVIS,DEL.PNAME,NEW.PNAME
00201 00040
00207 00041 DSCR MATCHING PROCEDURE ROUTINES, CALMP,RESMP,SUCFA1
00212 00042 NOGLOB <
00213 ENDMK
⊗;
COMMENT ⊗HISTORY
AUTHOR,REASON
021 202000000065 ⊗;
COMMENT ⊗
VERSION 16-2(53) 4-5-73 BY JRL BUG #LY# GLOBAL PROPS BEING DESTROYED
VERSION 16-2(52) 4-5-73
VERSION 16-2(51) 4-2-73 BY JRL DON'T ALLOW PNAMES FOR ANY
VERSION 16-2(50) 3-20-73
VERSION 16-2(49) 3-20-73
VERSION 16-2(48) 3-20-73 BY JRL DON'T ERASE ASSOCIATIONS WHEN DELETE BTRIP
VERSION 16-2(47) 2-27-73 BY JRL FIX BYTE POINTERS FOR PROPS
VERSION 16-2(46) 2-19-73 BY JRL FLUSH POPTOP (NOW COMPILED INLINE)
VERSION 16-2(45) 2-13-73
VERSION 16-2(44) 1-28-73 BY JRL HAVE DELETE TO A FORGET ALL TO CONTEXT ITEMS
VERSION 16-2(43) 1-25-73 BY JRL ADD ? TYPE ASSOCIATIVE BOOLEANS
VERSION 16-2(42) 1-23-73 BY JRL MAKE ANY AND UNBOUND DISTINCT,DETECT ANY EVERYWHERE
VERSION 16-2(41) 1-23-73 BY JRL MAKE PROPS FIELD 12 BITS WIDE
VERSION 16-2(40) 1-22-73 BY JRL BRITM RETURNS NIC(IF FAIL) HANDLE(X ASSOC X≡FOO)
VERSION 16-2(39) 1-22-73
VERSION 16-2(38) 1-5-73 BY JRL DCS ALLOW UNBOUND IN SETS,LIST
VERSION 16-2(37) 1-5-73
VERSION 16-2(36) 1-5-73
VERSION 16-2(35) 1-5-73
VERSION 16-2(34) 12-8-72 BY JRL ADD O≡V DERIVED SET
VERSION 16-2(33) 12-4-72 BY DCS FIX F1 SEARCH BUG
VERSION 16-2(32) 12-1-72 BY JRL BUG #KP# FDONS DESTROYED AC A
VERSION 16-2(31) 11-26-72 BY JRL ADD POTENTIAL ANY xor ANY≡ANY SEARCH
VERSION 16-2(30) 11-18-72 BY JRL CHANGE HASH TABLE TO ONE WORD POINTERS TO CONFLICT LISTS
VERSION 16-2(29) 11-10-72 BY JRL ADD PROPS TO LEAP INIT
VERSION 16-2(28) 11-9-72 BY JRL ADD BNDTRP ROUTINE (BINDING ASSOC BOOL)
VERSION 16-2(27) 11-8-72 BY JRL MAKE INFTB INTO BYTE POINTER
VERSION 16-2(26) 10-16-72 BY jrl update item codes to include contexts
VERSION 16-2(25) 10-9-72 BY JRL GIVE MAINPI ETC TYPES, DON'T ALLOW UNBOUND IN MAKES,SETS,LIST
VERSION 16-2(24) 10-4-72 BY JRL BUG #JL# BNDFOR TURNED OFF FOR SETS
VERSION 16-2(23) 10-2-72 BY JRL BUG #JJ# MULTPLE PROCESS STUFF WAS DESTROYING FP2 LIST
VERSION 16-2(22) 10-2-72 BY JRL BUG #JI# FIX IFGLOBAL
VERSION 16-2(21) 9-17-72
VERSION 16-2(20) 9-17-72
VERSION 16-2(19) 9-17-72
VERSION 16-2(18) 9-11-72 BY JRL TURN OFF BNDFOR BIT WHEN FETCHING ? LOCALS
VERSION 16-2(17) 9-7-72 BY JRL ADD ROUTINES TO STACK ?LOCALS
VERSION 16-2(16) 8-25-72 BY JRL CHANGE CALL TO DELETE FROM MPFAIL
VERSION 16-2(15) 8-25-72 BY JRL MAINTAIN FRLOC AS CURSCB FOR PROCESSES
VERSION 16-2(14) 8-24-72 BY JRL ADD MATCHING PROCEDURE ROUTINES
VERSION 16-2(13) 8-23-72 BY JRL CHANGE FORGO TO HANDLE DISPLAY ITEMVARS
VERSION 16-2(12) 8-22-72 BY RHT BE SURE THAT LEAP IS INITED WHEN NEED
VERSION 16-2(11) 8-10-72 BY DCS MAKE LINK GO IN RIGHT SEG
VERSION 16-2(10) 8-7-72 BY RHT CHANGE LPINI LINKAGE
VERSION 16-2(9) 7-24-72 BY JRL ADD GLOBAL-LOCAL CHECKING MAKES,ERASES,DELETES
VERSION 16-2(8) 7-2-72 BY JRL LPINI CALLED FROM ALLOC IN GOGOL
VERSION 16-2(7) 6-8-72 BY DCS BUG #HP# RETURN NULL STR FROM CVIS IF NO PNAME
VERSION 15-6(6) 2-22-72
VERSION 15-6(5) 2-20-72
VERSION 15-2(4) 2-6-72 BY DCS BUG #GC# CONSISTENCY ABOUT FIRST ACTUAL ITEM #
VERSION 15-2(3) 2-1-72 BY DCS USE SYMBOLIC (HEAD-DEFINED) INDICES IN SPACE TABLE
VERSION 15-2(2) 12-22-71 BY DCS REMOVE SAILRUN
VERSION 15-2(1) 12-2-71 BY DCS INSTALL VERSION NUMBER
⊗;
SUBTTL Leaping runtime routines. Sept. 1972.
LSTON (LEPRUN)
IFNDEF UPPER,<↓UPPER←←0>
IFNDEF LOWER,<↓LOWER←←0>
IFNDEF ALWAYS,<↓ALWAYS←←0>
IFNDEF SEGS,<↓SEGS←←0>
IFNDEF GLOBSW,<↓GLOBSW←←0>
IFNDEF RENSW,<↓RENSW←←0>
BEGIN LEAP
INTERNAL LEAP,CVIS,CVSI,NEW.PNAME,DEL.PNAME,TYPEX,TYPEIT,LISTX
IFE ALWAYS,<ENTRY LEAP,CVIS,CVSI
TITLE LEAP
EXTERNAL GOGTAB,ARCOP,CORGET,CORREL,ARMAK,ARYEL,TERMIN,RESUME
EXTERNAL SPRPDA,RUNNER,DADDY,CURSCB,SPROUT
EXTERNAL .SKIP.,DATM,LKSTAT,INFTB,X11,X22,X33,SAVE,RESTR,EQU
EXTERNAL PROPS,STACSV,STACRS
EXTERNAL FP1DON,FP2DON,SDESCR,CORGZR,FPEES,ALLFOR,FSAV,FREST
INTERNAL COPARR,ARRRCL,RECQQ,CATLST,LPINI
>
REN <
TWOSEG 400000
RELOC 400000
USE HIGHS
USE
RELOC
USE HIGHS
>;REN
COMMENT ⊗
These are the leap runtime routines. If you can believe it,there
is only one entry, LEAP. On entry FLAG contains a
control word. The right half specifies
a routine name (see table of routines). The left half has
various bits -- such as:
BOUND
BINDING **during foreach lists only.
SETT **these bits are present for all (3) arguments.
SETT is passed in but never used since without set arguments
to MAKE,ERASE etc, it is superfluous
FOREA -- says that this call is inside a foreach list.
SETOP -- this is a set type thing (e.g. x ε S)
BRACKET -- this is a bracketed search.
GLOB <
GLBSRC -- this is a global model operation
>;GLOB
Since there is no elegant way of drawing spaghetti with characters,
I will refrain from describing here the mess that these
routines build and destroy (at random).
⊗
;ac definitions.
IFNDEF A,<
A←←1 ↔ B←←2 ↔ C←←3 ↔ D←←4
>
↓FLAG ←←5
FP←6 ↔ FRTAB←TAC1 ↔ FPD←10 ↔ PNT←11
GLOB <
TABL←←7
>;GLOB
NOGLOB <
TABL ←← USER ;MAKE IT THE SAME AS USER.
>;NOGLOB
ITLEN←=12 ;ITEM NUMBERS ARE 12 BITS LONG.
;LENGTHS OF VARIOUS THINGS.....
PHASLN ←← =128 ;LENGTH OF PNAME HASH TABLE
HASLEN←←777 ;MUST BE OF THIS FORM.
;I.E. 2↑N-1 .(THIS IS LENGTH OF HASH TABLE)
INFOLEN←←7777 ;MAXIMUM NUMBER OF ITEMS.
TOPITM ←←7777 ;DITTO...
GLOB <
GBRK ←← 6000 ;LOCAL - GLOBAL ITEM NUMBER BREAK
;MAXIMUM GLOBAL ITEM # IS 7776
>;GLOB
;FOREACH BLOCK TEMPLATE.
;THIS IS THE "SEARCH CONTROL BLOCK" -- ONE IS MADE FOR EACH KIND
;OF ASSOCIATIVE SEARCHING ROUTINE CALLED. THE FPD STACK HAS GOOD
;MASKS, TEMPORARY POINTERS, AND A-O-V INFORMATION IN IT.
SATNO←←MAXLOC ;MAX NO. OF SATISFIERS.(foreach locals)
;CURRENTLY =10
;** FOLLOWING ARE INDICES INTO SEARCH CONTROL BLOCK (USUALLY "FRTAB")
FPDP←←0 ;FOREACH PUSHDOWN POINTER.
MOVEA←←1 ;INSTRUCTION TO EXECUTE TO LOAD AC "A"
;WITH THE CURRENT SATISFIER FOR THE LOCAL NUMBER
;IN "A"
MOVEB←←2 ;SAME FOR AC "B"
MC←←3 ;BYTE POINTER FOR DEPOSITING SATISFIERS.
INDEX4←4 ;INCREMENT TO SEARCH ROUTINE FOR ? LOCALS
SCNT←←5 ;NUMBER OF CORE SATISFIERS FOR THIS SEARCH.
SATIS←←6-1 ;START OF SATISFIERS.
;EACH CELL HAS :
; RH → USER CORE ADDRESS OF VARB.
; LH CURRENT SATISFIER ITEM NUMBER.
; (PUT THERE WITH "MC", RETRIEVED
; WITH "MOVEA" OR "MOVEB"
;Note that SCNT is used for depositing satisfiers
;to ANY and thus when count really wanted should
;loaded with HRRE
OLDSAT ←← SATIS+1+SATNO ;BLOCK OF OLD VALUES OF FOREACH LOCALS
FPDL←←OLDSAT+SATNO ;PUSH DOWN AREA.
;DISPLACEMENTS IN FPD STACK FOR VARIOUS THINGS.
; USED BY THE SEARCH ROUTINES TO FIND ARGUMENTS LEFT BY
; THE FOREACH SEARCH CALLER.
T2←←2
TT1←←3
MASK←←4
ATTP←←5
ITMP←←5
OBJP←←6
SETP←←6
VALP←←7
LENFPD←←10 ;LENGTH OF AN FPD STACK ENTRY
FPDLEN←←=10*LENFPD ;FOREACH PUSHDOWN LIST LENGTH
;ALLOW 10 SEARCHES
FRCHLEN←←FPDL+FPDLEN+2 ;TOTAL LENGTH.
SCBLNK←←FRCHLEN-1 ;FRCHLEN-1 OFFSET OF SCBLINK
;BITS IN LEFT HALF OF LOCAL ITEMVARS
CDISP ←← 100000 ;A DISPLAY MUST BE CALCULATED
MPPAR ←← 200000 ;THIS IS A ? ITEMVAR PARAMETER
POTUNB ←← 400000 ;THIS LOCAL IS ONLY POTENTIALLY UNBOUND
;IF POTUNB THEN SATISFIER CAN CONTAIN FOLLOWING
BNDFOR ←← 400000 ;THIS LOCAL WAS BOUND ON ENTRY
DSCR FOREACH INTERPRETATION EXAMPLE
⊗;
COMMENT @
THE THREE FOLLOWING DEFINITIONS PERTAIN TO THE (SAY) THREE ARGUMENTS
IN A FOREACH SEARCH SPECIFICATION: IF I SAID:
FOREACH X | A⊗X≡B AND X IN FOOSET DO...
THE CODE WOULD BE:
MOVEI TAC1,.+4 ;ADDRESS SATIS INFO BLOCK
MOVEI FLAG,11 ;ROUTINE NO. 11, START A FOREACH
PUSHJ P,LEAP
JRST .+4 ;JUMP AROUND SATIS INFO BLOCK
JRST 2232323 ;WHERE TO GO WHEN FOREACH ALL DONE.
1 ;NUMBER OF FREE LOCALS
X ;ADDRESS OF THE ITEMVAR X.
PUSH P,[A] ;ITEM A
PUSH P,[1] ;FIRST SATISFIER
PUSH P,B ;ITEMVAR B.
MOVE FLAG,[XWD 20,2] ;SPECIFIES THAT OBJECT IS BEING BOUND
;IN THIS OPERATION ("BINDING"), AND
;TO USE SEARCH 2 (OBJECT UNBOUND).
PUSHJ P,LEAP
PUSH P,[1] ;FIRST SATISFIER
PUSH P,FOOSET ;SET
MOVE [XWD 20410,7] ;SET SEARCH. SPECIFIES THAT THIS IS
;A SET OPERATION ("SETOP") AND THAT
;THE FIRST ARG. IS A BOUND SATISFIER.
PUSHJ P,LEAP
MOVEI FLAG,12 ;PUT SATISFIERS DOWN IN CORE....
PUSHJ P,LEAP
@
;VARIOUS DEFINITIONS OF BITS IN THE CONTROL WORD:
; THIS IS THE CONTROL WORD IMBEDDED UNDER THE PUSHJ P,LEAP.
; THESE BITS ARE IN THE LEFT HALF, AND SPECIFY MODIFICATIONS
; ON THE ROUTINE NUMBER MENTIONED IN THE RIGHT HALF.
BOUND←←4 ;THESE NEXT 3 REPEATED FOR A,O AND V.
BINDING←←2
SETT←←1
FOREA←←40000 ;A FOREACH SEARCH (NOT USED)
SETOP←←20000 ;A SET SEARCH IN A FOREACH.
GLOB <
GLBSRC←←200000 ;GLOBAL SEARCH SPECIFIED.
>;GLOB
BRACKET←←400000 ;MUST BE SIGN BIT.
;MEANS A BRACKETED TRIPLE SEARCH IN
;FOREACH CONTEXT.
ATTPOS←←6 ;POSITION IN THE WORD.....
OBJPOS←←3
VALPOS←←0
;BITS IN THE DATA STRUCTURES OF LEAP.
BRABIT←←400000 ;MUST BE SIGN BIT.
;ON IF NEXT GUY ON VALUE LIST IS A
;BRACKETED TRIPLE.
;THIS BIT IS USED BOTH IN THE FOREACH SPEC.
;FOR THE SEARCH, AND IN THE LEAP LIST
;STRUCTURES CREATED.
COMMENT ⊗THERE IS A TBITS TABLE CALLED TBTBL IN EVAL -- IN FILE IOSER ⊗
;THE MAGIC MACRO TO HASH
DEFINE HASH (X,Y,Z) <
IFDIF <X><Y>,<MOVE X,Y>
LSH X,1
XOR X,Z
AND X,HASMSK(TABL) ;THE MASK
ADD X,HASTAB(TABL) ;AND THE BOTTOM OF THE AREA.
>
;MAGIC MACRO TO TEST FOR BRACKETED TRIPLE.
NOGLOB <
DEFINE BRACKP (X) <TRZE X,BRABIT> ;SKIPS IF NO BRACK. TRIPLE.
DEFINE BRACKN (X) <TRZN X,BRABIT> ;SKIPS IF BRACKETED TRIPLE.
>;NOGLOB
GLOB <
DEFINE BRACKP (X) <
CAIN TABL,GLUSER
JRST [JUMPE X,.+ 3 ↔ TRON X,BRABIT
JRST .+2
JRST .+3]
TRZE X,BRABIT
>
DEFINE BRACKN (X) <
CAIN TABL,GLUSER
JRST [JUMPE X, .+2 ↔ TRON X,BRABIT
JRST .+3
JRST .+2]
TRZN X,BRABIT
>
>;GLOB
NOEXPO <
NOGLOB <
INTERNAL .MES1,.MES2
.MES1:.MES2: POP P,(P) ↔ POPJ P,
>;NOGLOB
INTERNAL DATERR
DATERR: ERR <INCORRECT ITEM # FOR GLOBAL DATUM>,1
POPJ P,
>;NOEXPO
DSCR LEAP ALLOCATION -- START OF PROGRAM.
Allocation (initially).
The initialization proceeds in several phases:
1. zero all the set variables.
2. accumulate counts of declared items and NEW estimates.
3. allocate hash table, datum table, info table, and frees.
4. initialize random other things (datum, foreach tables)
5. initialize printnames, item types for declared items
⊗
;MACRO TO GET LEAP CORE.
DEFINE LPCOR (SIZE,PLACE) <
IFDIF <SIZE><>,<MOVEI C,SIZE>
PUSHJ P,CORGZR
IFDIF <PLACE><>,<MOVEM B,PLACE(TABL)>
>
DSCR INITIT - INITIALIZE ITEM TYPE FOR DECLARED ITEMS ⊗
COMMENT ⊗ AC A is assumed to contain address of type info block
from SPLNK. Type info block contains word containing N
the number of declared items followed by N words containing
item # ,, type index.
this routine destroys contents ac A. ⊗
INITIT: ;CALLED BY PUSHJ FROM LPINI
PUSH P,B ;GET SOME AC'S TO PLAY WITH
PUSH P,C
GLOB <
MOVEI TABL,GLUSER ;POINT TO GLOBAL STUFF
PUSH P,[HRRM B,(C)] ;USED TO INSERT INTO GLOBAL INFOTAB
HRRZ B,INFOTAB(TABL) ;ADDRESS INFOTAB
ADDM B,(P)
>;GLOB
PUSH P,[HRRM B,(C)]
HRRZ B,INFOTAB(USER) ;
ADDM B,(P)
MOVN B,(A) ;NEG. COUNT OF DECLARED ITEMS
JUMPE B,ITRETRN ;NO DECLARED ITEMS?
ADDI A,1 ;POINT TO FIRST "DATA" WORD
HRL A,B ;MAKE AOBJN POINTER
LPINIT: HRRZ B,(A) ;GET TYPE CODE
HLRZ C,(A) ;GET ITEM NUMBER
GLOB <
CAIL C,GBRK
;; #LY# GLOBAL ITEM TYPES SHOULD ONLY BE INITIALIZED ONCE.
JRST [SKIPN LEPINI ;IF GLOBAL ALREADY INITIALIZED DON'T DESTROY PROPS
XCT -1(P) ;PUT IN GLOBAL INFOTAB
JRST .+1]
;; #
>;GLOB
SKIPL UUO1(USER) ;IF NO LOCAL MODEL DON'T
XCT (P) ;PUT IN LOCAL INFOTAB
CAIE B,STTYPE ;STRING ITEM?
JRST ADDONE ;NO.
PUSHJ P,SDESCR ;GET A STRING DESCRIPTOR
POP P,@DATM ;SAVE AS DATUM
ADDONE: AOBJN A,LPINIT ;THROUGH?
ITRETRN:
NOGLOB <
SUB P,X11 ;REMOVE HRRM
>;NOGLOB
GLOB <
MOVEI TABL,(USER) ;REFER TO LOCAL MODEL AGAIN
SUB P,X22 ;REMOVE BOTH HRRM'S
>;GLOB
SKIPGE UUO1(USER) ;IF NO LOCAL MODEL
JRST ITRET2 ;JUST RETURN
MOVEI C,EVTYPI ;EVENT TYPE ITEM
MOVEI B,1 ;CODE FOR NO DATUM
MOVEM B,@INFTB ;STORE CODE
MOVEI C,NIC ;NIC ITEM
MOVEM B,@INFTB ;ALSO UNTYPED ITEM
ITRET2:
POP P,C
POP P,B
POPJ P,
NOLOW <
NOUP <
REN <
USE
>;REN
LPLNK: 0↔LPINI
0
LINK %INLNK,LPLNK
REN <
USE HIGHS
>;REN
>;NOUP
↑LPINI2: ERR <LEAP SHOULD HAVE BEEN INITIALIZED>,1,LIN.1
HERE(LPINI)
SKIPN HASMSK(USER) ;LEAP INITIALIZATION ROUTINE.
POPJ P, ;DONT NEED IT
LIN.1: PUSH P,TAC1 ;NOT SAVED IN CORGET AND FRIENDS.
GLOB <
WRITSEC
>;GLOB
MOVE B,SETLNK(USER) ;CLEAR OUT ALL SETS LINKED BY COMPILER
JUMPE B,LPALLO ;NO SETS!!!!
GOSET: MOVE C,-1(B)
SETZM (C) ;ZERO THE SET.
AOBJN C,.-1
HRRZ B,(B)
JUMPN B,GOSET ;CDR OF LIST.
LPALLO: ;SEARCH SPACE ALLOCATION INFORMATION.
SETZB C,D ;ACCUMULATE MAXIMUM ITEM COUNT.
GLOB <
MOVEI LPSA,7777
>;GLOB
HRROS UUO1(USER) ;ASSUME NO LEAP LOCAL MODEL.
MOVE A,SPLNK(USER) ;ALLOCATION LINK POINTER
ITMWQ: JUMPE A,ITMDON ;0 WHEN DONE.
HRRE TEMP,$ITNO(A) ;TOP ITEM NUMBER USED.
CAILE TEMP,10 ;THERE ARE 7 DUMMIES.
; THIS WAS A CAILE -- I THINK IT'S BETTER THIS WAY -- DCS 10-6-71
; THIS IS A CAILE AGAIN -- OTHERWISE THE HAND/EYE SYSTEM GETS THE ERROR MESSAGE
; EVERY TIME - KKP 10-25-71
JRST [SKIPE C ;C USED AS FLAG,NONZERO IF WE'VE BEEN HERE BEFORE
TERPRI <WARNING: TWO PROGRAMS WITH ITEMS IN THEM>
HRRZS UUO1(USER) ;SAY LOCAL LEAP MODEL
MOVE C,TEMP
JRST .+1]
SKIPLE TEMP,$NWITM(A);IF ITEMS REALLY REQUESTED,
HRRZS UUO1(USER) ;SAY LOCAL LEAP MODEL
ADD D,TEMP ;ESTIMATE OF NEW ITEMS REQUIRED.
GLOB <
CAML LPSA,$GITNO(A) ;JUST SO K PINGLE NEED NOT COMPILE WITH GLOB MODEL.
MOVE LPSA,$GITNO(A) ;GLOBAL ITEMS ALLOCATED.
;CANNOT EXCEED 7776...
>;GLOB
HRRZ A,(A) ;GO DOWN LINK.
JRST ITMWQ
ITMDON: ;FINISHED WITH SPACES.
CAIGE C,10 ;MAKE SURE ITEMS 10 AND BELOW NOT ALLOCATED
;;#GC# DCS 2-6-72 (1-1) BE CONSISTENT
MOVEI C,10 ;NEXT NEW WILL YIELD 11
;;#GC# (1-1) FIRST DECLARED WAS 11 -- NOW IF NONE DECLARED, FIRST IS 11
MOVEM C,MAXITM(USER);TOP ITEM ALLOCATED.
MOVEI FP,HASLEN&777777;FOR THE HASH TABLE MASK.
MOVEM FP,HASMSK(USER) ;AND SAVE
GLOB <
;GLOBAL MODEL INITIALIZATION.
AOSE LEPINI ;INITED ALREADY?
JRST LNONIT ;YES
MOVEM FP,HASMSK+GLUSER;IN TWO PLACES.
MOVEI TABL,GLUSER ;
MOVEM LPSA,MAXITM(TABL);AS WE ACCUMULATED IT.
MOVEI D,GBRK ;ADJUST FOR LOCAL -GLOBAL DIFFERENCE.
MOVEI C,TOPITM-GBRK+1 ;NUMBER OF GLOBAL ITEMS TO ALLOC.
PUSHJ P,SPALLO ;AND ALLOCATE
MOVEM A,GINFTB ;GLOBAL TYPE-CHECKING
HRLI A,(<POINT 12,(3),29>) ;FOR PROPS FIELD
MOVEM A,GPROPS
MOVEM B,GDATM ;GLOBAL DATUM REFERENCES.
PUSHJ P,FPEES ;FREES.
LNONIT:
MOVEI TABL,(USER) ;REFER TO LOW CORE AGAIN
>;GLOB
SKIPGE UUO1(USER) ;DOES USER REALLY WANT LOCAL MOD?
JRST INDONE ;THIS IS TO AVOID HAVING SOME
;POOR LOSER WHO ONLY WANTS GLOBAL
;ARRAYS GETTING 15 K CORE FOR LEAP!
NOGLOB <
ADDI C,100(D) ;MAXIMUM EXPECTED NEWS IN ADDITION.
CAILE C,TOPITM ;IF OVER THE TOP, THEN...
>;NOGLOB
MOVEI C,TOPITM ;MAKE IT RIGHT.
MOVEM C,ITMTOP(USER) ;SAVE AS MAX PERMISSIBLE ITEM NUMBER.
MOVNI TEMP,-3(C) ;INIT FREITM(USER)
SUB TEMP,MAXITM(USER)
MOVNM TEMP,FREITM(USER);NUMBER OF UNALLOCATED LOCAL ITEMS.
GLOB <
MOVEI D,0
PUSH P,SPDON ;DUMMY RETURN ADDRESS.
>;GLOB
SPALLO: PUSH P,C
LPCOR (,) ;GET CORE FOR VALUE LINKS, ETC.
GLOB <
SUBI B,(D) ;SUBTRACT OFF LOWER BOUND.
>;GLOB
HRLI B,(<POINT 6,(C),35>);MAKE INTO INDIRECT WORD
MOVEM B,INFOTAB(TABL) ;RECORD IT.
LPCOR (HASLEN+1,HASTAB);HASH TABLE SPACE.
POP P,C ;RESTORE SIZE
LPCOR (,) ;AND FOR DATUMS.
GLOB <
SUBI B,(D) ;ADJUST IF NECESSARY
>;GLOB
HRLI B,3 ;ACCUMULATOR NUMBER FOR DATUM.
MOVEM B,DATAB(TABL) ;RECORD IT.
SETZM OLDITM(TABL) ;RESTART THE OLD ITEM LIST.
MOVE A,INFOTAB(TABL) ;FOR DYNAMIC TYPE-CHECKING
HRLI A,(<POINT 6,(3),35>);BYTE PTR. FOR TYPE CHECKING
GLOB <
SPDON: POPJ P,.+1
>;GLOB
MOVEM A,INFTB ;FOR TYPE CHECKING
HRLI A,(<POINT 12,(3),29>) ;BYTE POINTER FOR PROPS FIELD
MOVEM A,PROPS
MOVEM B,DATM ;THIS IS FOR REFERENCING DATUMS.
; **** COMMENT HERE ON BUFACS PROBLEM *****
INDONE: LPCOR (FRCHLEN,LEABOT) ;GET CORE FOR "ERASE" SCB
SETZM SCBLNK(B) ;NOT CONSIDERED NESTED FOREACH
SETZM SCBCHN(USER) ;NO FREE SCB'S
MOVEI TAC1,(USER) ;SO FRGO WON'T CAUSE ILL MEM REF.
JSP FP,FRGO ;INITIALIZE "ERASE" SCB
;GET ONE AND TWO WORD FREES
GLOB <
SKIPL UUO1(USER) ;WANT LOCAL LEAP?
PUSHJ P,GFREES ;WILL TRY TO USE HOLES IN INFOTAB,DATAB FOR ALLOC.
MOVEI TABL,(USER) ;WE'RE BACK TO LOWER SEGMENT STUFF
>;GLOB
SKIPL UUO1(USER) ;DON'T GET FREES IF NO LOW-SEGMENT ITEMS
PUSHJ P,FPEES ;GET FREE STORAGE.
MOVE B,SPLNK(USER) ;SPACE ALLOCATION LIST
PNMTYPLP:JUMPE B,INITDN ;THROUGH?
PUSH P,B ;SAVE THROUGH CALLS
SKIPE A,$TINIT(B) ;ITEM TYPE INITIALIZATION
PUSHJ P,INITIT
SKIPE A,$PINIT(B) ;PRINTNAME INITIALIZATION
PUSHJ P,INTNAM
POP P,B
HRRZ B,(B) ;CDR SPACE ALLOCATION LIST
JRST PNMTYPLP
INITDN:
GLOB <
NOSEC
>;GLOB
POP P,TAC1 ;RESTORE AC.
POPJ P, ;GO AWAY...
DSCR INTERLOCKS FOR LEAP GLOBAL MODEL
PMUTX,VMUTX,PNOENT,VNOEN,RDSEC,WRITSEC,NOSEC
⊗
GLOB <
COMMENT ⊗ THE BASIC STRATEGY IS TO CONSIDER LEAP ACTIONS AS DIVIDED
INTO TWO CLASSES. THOSE WHICH READ ONLY, AND THOSE WHICH BOTH READ
AND WRITE. ANY NUMBER OF JOBS MAY BE ALLOWED TO ENTER LEAP IF
ALL THEY WANT TO DO IS READ AND THERE IS NO JOB CURRENTLY IN LEAP
WHICH WILL WRITE. THE SOLUTION TO THE CRITICAL SECTION PROBLEM
IS TAKEN FROM THE COURTOIS, ET AL ARTICLE IN CACM, OCT. 1971 ⊗
;MACROS TO AID US
DEFINE PMUTX <
PUSHJ P,PMUTXR
>; PREFORMS P OPERATION ON SEMAPHORE MUTEX
DEFINE VMUTX <
SOS MUTEX
>; PREFORMS V OPERATION ON SEMAPHORE MUTEX
DEFINE PNOENT <
PUSHJ P,PNOENR
>; PREFORMS P OPERATION ON SEMAPHORE NOENTER
DEFINE VNOENT <
SOS NOENTER
>; PERFORMS V OPERATION ON SEMAPHORE NOENTER
DEFINE WRITSEC <
PUSHJ P,ENTWRT
>; MAKE SURE INSIDE OF WRITING SECTION
DEFINE RDSEC <
PUSHJ P,ENTRD
>; MAKE SURE INSIDE OF READING SECTION
DEFINE NOSEC <
PUSHJ P,NOSECR
>; EXIT WHATEVER KIND OF SECTION WE'RE IN IF ANY
;ROUTINE THAT DO THE WORK FOR MACROS
↑AOSENT: ;TO START READING SECTION
TLNN FLAG,GLBSRC ;GLOBAL OPERATION
POPJ P, ;NO.
PMUTX ;MANIPULATING READCOUNT CRITICAL
AOSN ENTERED ;INC COUNT, FIRST JOB IN?
PNOENT ;YES, LOCK OUT WRITING JOBS
VMUTX ;EXIT THIS CRIT. SECTION
POPJ P, ;RETURN
↑SOSENT: ;TO EXIT READING SECTION
TLNN FLAG,GLBSRC ;GLOBAL OPERATION
POPJ P, ;NO.
PMUTX ;MANIPULATING READCOUNT CRITICAL
SOSGE ENTERED ;DEC COUNT,OTHERS READERS AROUND?
VNOENT ;NO. FREE CRIT. SECT.
SETZM LKSTAT ;NOT IN ANY TYPE OF SECTION
VMUTX ;EXIT THIS CRIT. SECT.
POPJ P, ;RETURN
↑PMUTXR: ;P(MUTEX)
AOSE MUTEX ;IF NOW=ZERO WE'RE O.K.
JRST [SOS MUTEX ;TOO BAD WE HAVE TO WAIT
PUSHJ P,WAIT1 ;SLEEP AWHILE
JRST .-1 ;TRY AGAIN
]
POPJ P, ;WE'RE IN CRIT. SECTION MUTEX
↑PNOENR: ;P(NOENTER)
AOSE NOENTER ;ZERO, WE'RE ALLOWED IN
JRST [SOS NOENTER ;WE HAVE TO WAIT
PUSHJ P,WAIT10 ;SLEEP SOUNDLY
JRST .-1]
POPJ P, ;WE'RE INSIDE.
ENTCHK: ;TO ENTER WRITING SECTION
PNOENT ;WAIT UNTIL WE CAN ENTER
PUSH P,A ;FREE AN AC
CALLI A,30 ;GET JOB NO.
MOVEM A,LKJBNO ;SAVE IN CASE ANYONE WANTS TO KNOW
POP P,A ;RESTORE A
POPJ P, ;RETURN
EXCHK: ;TO EXIT FROM WRITING SECTION
VNOENT ;EXIT WRITING, ALLOW READERS BACK IN
SETZM LKSTAT ;NOT IN ANY SECTION
SETZM LKJBNO ;CLEAR JOB NUMBER
POPJ P, ;RETURN
↑↑WAITQQ:
WAIT1: PUSH P,A ;SAVE AC
MOVEI A,1 ;ONE SECOND SLEEP
JRST WAIT10+2
WAIT10: PUSH P,A ;SAVE AN AC
MOVEI A,10 ;10 SEC. WAIT
CALLI A,31 ;BEDDY-BYE
POP P,A ;RESTORE A
POPJ P, ;RETURN
ENTWRT: ;FORCE INTO WRITING SECTION
TLNN FLAG,GLBSRC ;IF NOT GLOBAL FORGET IT.
POPJ P,
SKIPGE LKSTAT ;ALREADY IN WRITING SECTION?
POPJ P, ;IF SO, RETURN
SKIPE LKSTAT ;IN READING SECTION?
PUSHJ P,SOSENT ;YES, EXIT FIRST
PUSHJ P,ENTCHK ;ENTER WRITING SECTION
SETOM LKSTAT ;MARK AS INSIDE WRITING SECTION
POPJ P,
ENTRD: ;FORCE INTO READING SECTION
TLNN FLAG,GLBSRC ;GLOBAL OPERATION?
POPJ P, ;NO FORGET IT.
SKIPLE LKSTAT ;ALREADY IN READING SECTION?
POPJ P, ;YES.
SKIPE LKSTAT ;IN WRITING SECTION?
PUSHJ P,EXCHK ;YES EXIT IT.
AOS LKSTAT ;MARK AS INSIDE READING SECTION
PUSHJ P,AOSENT ;ENTER SECTION
POPJ P,
NOSECR: ;EXIT ANY SECTION
SKIPN LKSTAT ;IN A SECTION?
POPJ P, ;NO, RETURN
SKIPG LKSTAT ;WRITING
PUSHJ P,EXCHK ;YES
SKIPE LKSTAT ;READING
PUSHJ P,SOSENT ;YES
POPJ P,
>;GLOB
DSCR MAIN DISPATCHER FOR LEAP
THIS IS THE MAIN ENTRY OF THIS CODE (I.E. "LEAP").
THE APPROPRIATE INTERPRETER ROUTINE IS CALLED.
****** AC'S SET UP FOR ALL INTERPRETER ROUTINES ******
USER SET UP TO GOGTAB.
UUO1(USER) CONTAINS THE USER'S RETURN ADDRESS.
FLAG CONTAINS CONTROL WORD.. UNTOUCHED
P PUSH-DOWN STACK HAS RETURN ADDRESS WORD POPPED OFF.
⊗;
HERE (LEAP) ;THIS HERE IS LEAP.
MOVE USER,GOGTAB
GLOB <
MOVEI TABL,(USER) ;AND FOR LOCAL TABLES.
>;GLOB
SKIPN HASMSK(USER) ;TEST TO SEE IF INITIALIZED ALREADY.
PUSHJ P,LPINI2 ;NO -- GO DO IT.
POP P,UUO1(USER) ;RETURN ADDRESS
GLOB <
TLNE FLAG,GLBSRC
MOVEI TABL,GLUSER ;REFER TO UPPER SEG.
RDSEC ;ENTER READING SECTION
>;GLOB
XCT ROUTABLE(FLAG) ;CALL THE ROUTINE.
↓LEAV: ;UNIFORM EXIT LOCATION.
GLOB <
PUSH SP,P ;UNCLEAN HACK.
MOVE P,SP ;USE STRING STACK TEMPORARILY.
NOSEC ;EXIT ANY SECTION
POP SP,P ;USE OLD STACK AGAIN
>;GLOB
JRST @UUO1(USER)
GLOB < ;MISCELLANEOUS....
INTERNAL GINFTB,GDATM,NOENTER,ENTERED,LKJBNO,MUTEX,GPROPS
MUTEX: -1 ;FOR CRITICAL SECTION CHANGING ENTERED
LKJBNO: 0
NOENTER: -1 ;GTR EQ 0 IF WRITING LOCKED OUT
GINFTB: 0 ;INDIRECT WORD FOR REFERING TO INFOTAB
GDATM: 0
GPROPS: 0 ;HOLDS BYTE POINTER FOR ACCESSING PROPS FIELD
LEPINI: -1
ENTERED: -1
;HERE IS A RESET ROUTINE.
INTERNAL RE.MOD
RE.MOD: SETOM NOENTER
SETOM ENTERED
SETOM QUETCH
SETZM MESQ
SETZM JOBCNT ;THIS REALLY RESETS THE WORLD.
SETZM LKJBNO
POPJ P,
>;GLOB
;DISPATCH TABLE FOR THE LEAP INTERPRETER.
;WHEN COMPILER OF (FEB 19) IN USE WILL HAVE TO CHANGE ROUTABLE
;TO REFLECT NEW NO-OPS
ROUTABLE:
REPEAT 12,<JRST FOREC> ;0-11 -- FOREACH SEARCHES.
JRST FORGO ;12 -- START OF FOREACH STAT.
PUSHJ P, FRPOP ;13 -- POP FOREACH SATISFIERS INTO CORE.
JRST DOAG ;14 -- LOOP AT END OF FOREACH STAT.
JRST FRFAL ;15 -- IF A FOREACH BOOLEAN IF FALSE.
PUSHJ P, MAKE ;16 -- MAKE AN ASSOCIATION.
JRST BMAKE ;17 -- MAKE A BRACKETED TRIPLE.
ESTART:
REPEAT 10,<PUSHJ P, ERASE> ;20-27 -- ERASES
PUSHJ P, ISTRIPLE;30 -- ISTRIPLE (FOO)
SELET1:
REPEAT 3,<PUSHJ P, SELECTOR>;31-33 FIRST,SECOND AND THIRD.
PUSHJ P, CORPOP ;34 -- CORE INTO SATISFIERS(INVERSE OF 12)
LD0: JRST LD1 ;35 -- DERIVED SETS -- INSIDE FOREACH.
JRST LD2 ;36
JRST LD3 ;37
DSTART: JRST D1 ;40 -- DERIVED SETS -- NORMAL.
JRST D2 ;41
JRST D3 ;42
JRST DELETE ;43 -- DELETE.
PUSHJ P, NEW ;44 -- REGULAR NEW.
PUSHJ P, NEWART ;45 -- NEW (ARITHMETIC VALUE)
JRST NEWARY ;46 -- NEW (ARRAY)
PUSHJ P, FDONS ;47 -- RELEASE THIS FOREACH STATEMENT.
PUSHJ P, PUTIN ;50 -- PUT X IN SET.
PUSHJ P, REMOV ;51 -- REMOVE X FROM SET.
PUSHJ P, SIP ;52 -- <A,B,C,D>
PUSHJ P, STIN ;53 -- BOOLEAN Xε SET ?
PUSHJ P, COUNT ;54 -- LENGTH OF SET.
PUSHJ P, UNIT ;55 -- COP OF SET.
PUSHJ P, UNION ;56 -- SET UNION
PUSHJ P, INTER ;57 -- SET INTERSECTION.
PUSHJ P, SUBTRA ;60 -- SET SUBTRACTION.
JRST STORITM ;61 -- STORE A SET OR ITEM FROM STACK.
JRST STORBUTDONTREMOVE ;62 -- SAME AS 61, BUT LEAVE ON STACK.
ERR <DRYROT-LEAP:ROUTABLE> ;63 -- USED TO BE POPTOP ITEM
JRST POPSET ;64 -- (NO LONGER IN COMPILED CODE)
;POP PERM SET INTO AC1
RELSTART:
REPEAT 6,<PUSHJ P, SETEST> ;65-72 -- SET RELATIONALS.
ISBEG:
REPEAT 10,< JRST ISIT > ;73-102 -- ANSWER TO A⊗B≡C ?
BSTART:
REPEAT 10,<JRST BRITM> ;103-112 -- FIND ITEM FOR [A⊗B≡C]
JRST ITMRY ;113 -- FOR INITIALIZING ARRAY ITEMS.
JRST ITMYR ;114 -- FOR INITIALIZING ARRAY ITEMS.
JRST STLOP ;115 -- LOP OF SET.
JRST BNDTRP ;116 -- BINDING FORM OF ASSOCIATIVE BOOLEAN
JRST SETCOP ;117 -- COPY A FORMAL SET.
JRST SETRCL ;120 -- RECLAIM A FORMAL SET.
PUSHJ P, CATLST ;121 -- CONCATENATE TWO LISTS
PUSHJ P, PUTAFTER ;122 -- INSERT IN LIST
PUSHJ P, PUTBEFOR ;123 -- INSERT IN LIST
JRST SELFETCH ;124 -- SELECT ITEM FROM LIST
PUSHJ P, TSBLST;125 -- LIST[EXPR TO EXPR]
PUSHJ P, FSBLST ;126 -- LIST[EXPR FOR EXPR]
JRST SETLXT ;127 -- TRANSFORM LIST TO SET
PUSHJ P, RPLAC ; 130 -- REPLACE ELEMENT OF LIST
PUSHJ P, REMX ;131 -- REMOVE ELEMENT FROM LIST
PUSHJ P, REMALL ;132 -- REMOVE ALL INSTANCES OF AN ITEM
PUSHJ P, PUTXA ;133 -- PUT AFTER INDEXED
PUSHJ P, PUTXB ;134 -- PUT BEFORE INDEXED
PUSHJ P, LSTMAK ;135 -- FOR MAKING UP LISTS
JRST CALMP ;136 -- SPROUT MATCHING PROCEDURE
JRST STK4VL ;137 -- STACK ? LOCAL AS VAL PARM
JRST STK4LC ;140 -- STACK ? LOCAL AS MP PARM
DSCR DISPATCH TABLE FOR THE FOREACH SEARCHES
INDEXED BY THE FLAG CONTROL WORD NUMBER -- RESULT
IS ROUTINE NUMBER TO EXECUTE. IF THE INDEX IS -1,
"FDONE" IS CALLED, WHICH AUTOMATICALLY FLUSHES THE
CURRENT FOREACH STATEMENT GROUP OF SEARCHES (I.E.
THE OUTERMOST SEARCH FAILED, AND IT IS TIME TO GO AWAY).
⊗;
FDONE
ETAB:
SEROUT: F1
F4
F3
F5
F2
F7
F6
F8
S2
S1
CALINDX:RESMP
DSCR ASSOCIATIVE SEARCH ROUTINES
⊗;
comment @
These are the 9 kinds of associative searches:
f1 A⊗O≡v
f2 A⊗O≡X
f3 A⊗X≡V
f4 X⊗O≡V
f5 X⊗Y≡V
f6 A⊗X≡Y
f7 X⊗O≡Y
s1 x ε S
s2 A ε S
These all use a "search control block" to describe the details
of the search. Any bound items have values in the FPD stack,
at -ATTP(FPD),-OBJP(FPD), and -VALP(FPD) depending whether
they are attribute, object or value. If these items are unbound,
then the stack entries contain the satisfier number (and hence
a description of a place where to put the result we find in the
search).
-TT1(FPD) and -T2(FPD) are used as temporaries by each routine --
they are used to store pointers into the data structure, and
to remember whether the search has been initialized once.
The initial values of these entries are -1 and 0 respectively.
Each search routine skips if it succeeds in finding an association
of the correct variety. In this case, register A points to the
2 word cell which stores that association. ERASE code counts
on this pointer, as do some other people (?).
If the search fails, or is exhausted, the normal (non-skipping)
return is taken.
@
;THE SEARCH ROUTINES.....
; A⊗O≡V
F1: AOSE -TT1(FPD) ;FIRST TEMP SAYS WE WRE HERE BEFORE.
POPJ P, ;RETURN -- HAVE BEEN THROUGH ONCE.
HASH (A,<-ATTP(FPD)>,<-OBJP(FPD)>)
SKIPN A,(A) ;SEE IF A-O-V IS THERE AT ALL.
POPJ P, ;IT IS NOT.
COMP: MOVE B,1(A) ;PICK UP A⊗O≡V
XOR B,-MASK(FPD) ;HAVE WE GOT IT?
JUMPN B,NO
YES: AOS (P)
POPJ P, ;SUCCESSFUL RETURN.
NO: TDNE B,[ 777777770000];DO A-O AT LEAST MATCH?
JRST [HRRZ A,(A) ;CONFLICT POINTER.
JUMPN A,COMP ;AND LOOK IF NONZERO
POPJ P,] ;FAILLLLLLllllll....
MOVE B,1(A)
TRNE B,7777 ;IS VALUE ZERO?
POPJ P, ;NO -- HENCE CANNOT SUCCEED.
HLRZ A,(A) ;VALUE LINK POINTS TO MULTIPLE HITS.
VALE: MOVE B,1(A) ;THIS IS IT.
CAMN B,-MASK(FPD) ;COMPARE
JRST YES
HRRZ A,(A) ;MULTIPLE HITS LIST
JUMPN A,VALE
POPJ P, ;FAILED.
; A⊗O≡X
F2: AOSE -TT1(FPD) ;BEEN HERE BEFORE?
JRST NEXT ;YESSIR
LDB B,[POINT ITLEN,-MASK(FPD),23] ;PICK UP OBJECT
LDB A,[POINT ITLEN,-MASK(FPD),ITLEN-1] ;PICK UP ATTRIBUTE
HASH (A,A,B)
SKIPN A,(A) ;CHECK TO SEE IF A-O-V IS THERE AT ALL
POPJ P, ;FAIL
COMP2: MOVE B,1(A)
TRZ B,7777 ;MASK OUT VALUE.
CAMN B,-MASK(FPD) ;SEE IF IT MATCHES...
JRST YES2
HRRZ A,(A) ;CONFLICT.
JUMPN A,COMP2 ;LOOP
POPJ P, ;FAILURE
YES2: MOVE B,1(A) ;PICK IT UP AGAIN.
TRNE B,7777 ;COULD STILL BE A MULTIPLE HIT.
JRST PUT ;NOPE
HLRZ A,(A) ;POINTER TO MULTIPLE HITS.
HRRZ C,(A) ;POINTER TO NEXT ONE.
MOVEM C,-T2(FPD) ;SAVE FOR NEXT TIME.
PUTA: MOVE B,1(A) ;PICK UP A-O-V
PUT: MOVE C,-VALP(FPD) ;LOCAL NUMBER FOR VALUE
DPB B,MC(FRTAB) ;PUT IN SATISFIER TABLE.
AOS (P)
POPJ P, ;SUCCESSFUL RETURN
NEXT: SKIPE -VALP(FPD) ;ANY ?
SKIPN A,-T2(FPD) ;GET NEXT ONE
POPJ P, ;NONE.
HRRZ C,(A) ;POINTER TO NEXT.
MOVEM C,-T2(FPD) ;SAVE IT.
JRST PUTA ;GO GET THE VALUE.
; A⊗X≡V
F3: AOSE -TT1(FPD) ;FIRST TIME
JRST NEXT3 ;NO
MOVE A,-VALP(FPD) ;VALUE
ADD A,INFOTAB(TABL) ;PREPARE TO GET VALUE LINK
HLRZ A,(A) ;VALUE LINK!
JUMPE A,CPOPJ ;IF ZERO, THERE IS NONE.
NN: MOVE B,1(A) ;PICK UP A-O-V
AND B,[BYTE (ITLEN) 7777,0,7777]
CAME B,-MASK(FPD) ;IS THIS THE ONE?
JRST NO3
HLRZ C,(A) ;VALUE LINK
BRACKP C ;IF BRACKETED TRIPLE THEN
HLRZ C,(C) ;PASS UP BRACKET NUMBER
MOVEM C,-T2(FPD)
MOVE C,-OBJP(FPD) ;OBJECT NUMBER
LDB B,[POINT ITLEN,1(A),23]
DPB B,MC(FRTAB) ;STORE IN SATISFIER TABLE.
AOS (P)
POPJ P,
NO3: HLRZ A,(A) ;VALUE LINK
BRACKP A
HLRZ A,(A) ;PAST BRACKETED ITEM NUMBER.
JUMPN A,NN ;LOOP UNTIL EXHAUSTED
POPJ P, ;EXHAUSTED.
NEXT3: MOVE A,-T2(FPD) ;GET THE LAST POINTER
SKIPE -OBJP(FPD) ;OBJECT = ANY?
JUMPN A,NN ; -- WANT TO DO SEARCH AGAIN.
POPJ P,
; X⊗O≡V
F4: AOSE -TT1(FPD) ;BEEN HERE BEFORE
JRST NEXT4 ;YES
MOVE A,-VALP(FPD) ;GET VALUE
ADD A,INFOTAB(TABL) ;PREPARE TO GET VALUE LINK
HLRZ A,(A) ;VALUE LINK!
JUMPE A,CPOPJ ;FAIL
NN4: MOVE B,1(A) ;A-O-V WORD
TLZ B,777700 ;MASK OFF ATTRIBUTE
CAME B,-MASK(FPD) ;IS THIS THE ONE?
JRST NO4
HLRZ C,(A) ;VALUE LINK
BRACKP C ;TEST FOR BRACKETED TRIPLE.
HLRZ C,(C) ;PASS UP BRACKET ID NUMBER
MOVEM C,-T2(FPD) ;SAVE FOR NEXT TIME.
MOVE C,-ATTP(FPD) ;ATTRIBUTE ID NUMBER
LDB B,[POINT ITLEN,1(A),ITLEN-1];ATTRIBUTE NUMBER
DPB B,MC(FRTAB) ;STORE IN SATISFIER TABLE.
AOS (P)
POPJ P, ;RETURN....
NO4: HLRZ A,(A) ;VALUE LINK
BRACKP A ;TEST FOR BRACKETED TRIPLE.
HLRZ A,(A) ;PAST BRACKETED ITEM NUMBER.
JUMPN A,NN4
POPJ P, ;FAILED.
NEXT4: MOVE A,-T2(FPD) ;POINTER
SKIPE -ATTP(FPD) ; IS THE ATTRIBUTE "ANY" ?
JUMPN A,NN4 ; NO -- TRY TO CONTINUE SEARCH
POPJ P,
; X⊗Y≡V
F5: MOVE A,-T2(FPD) ;FOR NEXT......
AOSE -TT1(FPD) ;BEEN HERE BEFORE?
JRST NEXT5 ;YUP
MOVE A,-VALP(FPD) ;VALUENUMBER
ADD A,INFOTAB(TABL) ;GET READY TO GET
HLRZ A,(A) ;VALUE LINK
JRST NEXT6 ;DO NOT CHECK FOR "ANY" FIRST TIME - KKP
NEXT5: SKIPN -ATTP(FPD) ;IF BOTH ARGS ARE "ANY", THEN
SKIPE -OBJP(FPD) ;RETURN IMMEDIATELY.
NEXT6: SKIPN A ;NOT THERE.
POPJ P,
HLRZ C,(A) ;NEXT VALUE POINTER
BRACKP C ;TEST FOR BRACKETED TRIPLE.
HLRZ C,(C) ;PASS UP BRACKET ID NUMBER
MOVEM C,-T2(FPD)
MOVE B,1(A) ;A-O-V WORD.
ROT B,ITLEN ;ATTRIBUTE IS NOW LOW.
MOVE C,-ATTP(FPD) ;ATTRIBUTE NUMBER
DPB B,MC(FRTAB) ;STORE IN SATISFIER TABLE.
ROT B,ITLEN ;OJECT IS NOW LOW
MOVE C,-OBJP(FPD) ;OBJECT ID NUMBER
CAMN C,-ATTP(FPD) ;ATTRIB AND OBJECT TO BE BOUND THE SAME?
JRST [LDB D,MC(FRTAB) ;BINDING FOR ATTRIB.
ANDI B,7777 ;JUST THE OBJECT
CAIN D,(B) ;THE SAME?
JRST AOSP ;YES EVERYTHING FINE?
MOVE A,-T2(FPD) ;TRY AGAIN
JRST NEXT6]
DPB B,MC(FRTAB)
AOSP: AOS (P)
POPJ P,
; A⊗X≡Y
F6: AOSE -TT1(FPD)
JRST [SKIPE -VALP(FPD);IS VALUE "ANY" ?
JRST GRT6 ;NO -- CONTINUE SEARCH.
SKIPE -OBJP(FPD);IS OBJECT "ANY"
JRST UPDAT ;NO -- GO TO NEXT OBJECT.
POPJ P, ;YES-- IT WAS ANY AND ANY
]
GLOB <
TLNE FLAG,GLBSRC ;IF GLOBAL SEARCH,THEN
JRST [MOVE A,MAXITM+GLUSER ;START THE COUNT AT LOWEST GL. ITEM-KKP
DPB A,[POINT ITLEN,-MASK(FPD),2*ITLEN-1] ;
MOVEI B,(A) ;SO WE DON'T HAVE TO DO LDB - KKP
JRST UPDAT+3]; AND JUMP AROUND IT - KKP
>;GLOB
UPDAT: MOVEI A,1⊗ITLEN ; 10000
ADDB A,-MASK(FPD) ; GO UP ONE ITEM NUMBER OBJ. POSITION
LDB B,[POINT ITLEN,A,2*ITLEN-1];OBJECT
GLOB <
CAIL B,TOPITM ;HAVE WE GONE OFF COMPLETELY??
POPJ P,
CAMGE B,MAXITM+GLUSER ; THIS MEANS ITEM IN GLOBAL AREA.
CAMG B,MAXITM(USER) ;THIS TESTS FOR ITEM IN LOCAL AREA.
JRST OKIT1 ;FINE...
MOVE B,MAXITM+GLUSER
DPB B,[POINT ITLEN,-MASK(FPD),2*ITLEN-1] ;PUT IT DOWN.
OKIT1:
>;GLOB
NOGLOB <
CAMLE B,MAXITM(USER) ;GONE FAR ENOUGH?
POPJ P, ;YES
>;NOGLOB
MOVE C,-OBJP(FPD) ;OBJECT ID NUMBER.
DPB B,MC(FRTAB) ;FILL SATISFIER
SETZM -T2(FPD) ;RESTART SEARCH
SETOM -TT1(FPD) ;RESTART SEARCH
GRT6: PUSHJ P,F2 ;A⊗O≡X
JRST UPDAT ;FAIL
SKIPE C,-VALP(FPD) ;ANY
CAME C,-OBJP(FPD) ;SAME OBJ,VAL ITEMVAR?
JRST AOSP ;NORMAL
LDB D,[POINT ITLEN,1(A),35] ;THE VALUE
LDB C,[POINT ITLEN,1(A),2*ITLEN-1];THE OBJECT
CAIE D,(C) ;THE SAME?
JRST GRT6 ;NO,TRY AGAIN.
JRST AOSP
; X⊗O≡Y
F7: AOSE -TT1(FPD)
JRST [SKIPE -VALP(FPD);IS VALUE "ANY"
JRST GRT7 ;NO -- GO AHEAD
SKIPE -ATTP(FPD);IS ATTRIBUTE "ANY" ?
JRST UPDAT7 ;NO -- GET ANOTHER ATTRIBUTE
POPJ P,] ;NO -- GO AHEAD
GLOB <
TLNE FLAG,GLBSRC ;IF GLOBAL SEARCH.
JRST [MOVE A,MAXITM+GLUSER; SEE COMMENT ON LAST SEARCH - KKP
DPB A,[POINT ITLEN,-MASK(FPD),ITLEN-1]; START COUNT
MOVEI B,(A)
JRST UPDAT7+3] ;AT RIGHT PLACE.
>;GLOB
UPDAT7: MOVSI A,(1⊗(2*ITLEN)) ; 1000
ADDB A,-MASK(FPD) ;UPDATE MASK ATTRIBUTE NUMBER
LDB B,[POINT ITLEN,A,ITLEN-1];ATTRIBUTENUMBER
GLOB <
CAIL B,TOPITM
POPJ P, ;GONE TOO FAR.
CAMGE B,MAXITM+GLUSER
CAMG B,MAXITM(USER) ;IN ALLOWED RANGE??
JRST OKIT2 ;YES
MOVE B,MAXITM+GLUSER ;NO -- BUMP IT UP.
DPB B,[POINT ITLEN,-MASK(FPD),ITLEN-1];PUT IT AWAY.
OKIT2:
>;GLOB
NOGLOB <
CAMLE B,MAXITM(USER) ;GONE FAR ENOUGH?
POPJ P,
>;NOGLOB
MOVE C,-ATTP(FPD) ;ATTRIBUTE ID NUMBER
DPB B,MC(FRTAB) ;FILL SATISFIER
SETZM -T2(FPD) ;RESTART SEARCH
SETOM -TT1(FPD) ;RESTART SEARCH
GRT7: PUSHJ P,F2 ; A⊗O≡X
JRST UPDAT7 ;FAIL
SKIPE C,-VALP(FPD) ;THE VALUE SAT NO.
CAME C,-ATTP(FPD) ;THE ATTIB SAT NO.
JRST AOSP ;NOT SAME OR VAL ANY
LDB D,[POINT ITLEN,1(A),35]; THE VALUE
LDB C,[POINT ITLEN,1(A),ITLEN-1]; THE ATTRIB
CAIE D,(C) ;THE SAME?
JRST GRT7 ;NO, TRY AGAIN
JRST AOSP
F8: ERR <ASSOCIATIVE SEARCH WITH NOTHING BOUND>,1
POPJ P, ;ALWAYS FAIL
; X ε S
S1: MOVE A,-T2(FPD) ;IN CASE OF NEXT
AOSE -TT1(FPD)
JRST NEXS1 ;BEEN HERE BEFORE
SKIPN A,-SETP(FPD)
POPJ P, ;NULL SET
HRRZ A,(A) ;GET PAST SET HEADER
NEXS1: JUMPE A,CPOPJ ;DONE
HLRZ B,(A) ;ITEM NUMBER
MOVE C,-ITMP(FPD) ;DESTINATION TEMP
DPB B,MC(FRTAB)
HRRZ B,(A) ;NEXT POINTER.
MOVEM B,-T2(FPD) ;FOR NEXT TIME.
AOS (P)
POPJ P, ;SUCCESS.
; A ε S
S2: AOSE -TT1(FPD) ;SO THAT YOU DON'T
POPJ P, ;GO THROUGH TWICE
SKIPN A,-SETP(FPD) ;PICK UP SET POINTER
POPJ P, ;NULL SET
HRRZ A,(A) ;PASS UP HEADER
NXT: JUMPE A,CPOPJ ;GONE TO END AND NOT FOUND.
HLRZ B,(A)
CAMN B,-ITMP(FPD) ;RIGHT ONE?
JRST YESS1
HRRZ A,(A)
JRST NXT
YESS1: AOS (P)
CPOPJ: POPJ P,
DSCR FORSET AND NOFOR -- MAKE A SEARCH CONTROL BLOCK
THESE ROUTINES TAKE ENTRIES OFF THE STACK (P) AND
MAKE UP SEARCH CONTROL BLOCKS BASED ON THESE ENTRIES AND
THE CONTENTS OF THE FLAG WORD. THESE ROUTINES ARE
CALLED BY THE FOREACH INTERPRETER, THE ERASE CODE,
AND SOME OF THE "IS THIS ASSOCIATION IN THE STORE"
ROUTINES.
THE DIFFERENCE BETWEEN THE ROUTINES IS THIS:
NOFOR HANDLES "ANY" CONSTRUCTS DIFFERENTLY. THE SEARCH ROUTINES
ARE CAPABLE OF CUTTING SHORT THEIR SEARCHES, BASED ON THE
EXISTENCE OF AN "ANY". THIS IS A FINE IDEA FOR THE
FOREACH STATEMENT, SINCE THE USER IS NOT INTERESTED
IN THE ACTUAL ITEMS WHICH WILL MATCH THE "ANY".
HOWEVER, THE ERASE CODE IS VITALLY INTERESTED, SINCE
IT MUST ERASE ALL OF THEM. SO:
NOFOR -- CALL IF YOU WANT SEARCH CONTROL BLOCK WHICH WILL
RETURN ON ALL SUCCESSFUL MATCHES TO "ANY"
FORSET -- CALL IF YOU WANT THE ABBREVIATED SEARCHES.
CALLS: BOTH WITH JSP LPSA,xxxx
⊗;
NOFOR: ;ONLY CALLED BY ERASE
MOVE FRTAB,LEABOT(USER) ;ALWAYS AVAILABLE BLOCK
SKIPE -2(P) ;ANY?
JRST NOFOR1 ;NO.
TLO FLAG,BINDING⊗ATTPOS
MOVEI A,1 ;THIS WILL BE THE SATISFIER NO.
MOVEM A,-2(P) ;THEN FIX.
NOFOR1: SKIPE -1(P)
JRST NOFOR2
TLO FLAG,BINDING⊗OBJPOS
MOVEI A,2 ;MAKE THEM ALL DIFFERENT
MOVEM A,-1(P)
NOFOR2: SKIPE (P)
JRST FORSET
TLO FLAG,BINDING⊗VALPOS
MOVEI A,3
MOVEM A,(P) ;THE COMPILER CAN'T REALLY DO THIS.
;SINCE ANY CAN NOW BE STORED IN ITEMVARS
FORSET: MOVE FPD,FPDP(FRTAB) ;PICK UP THE LEAP PUSH-DOWN POINTER.
TLNE FLAG,SETOP
AOBJN FPD,P2 ;NO ENTRY IF A SET.
TLNE FLAG,BRACKET ;IF BRACKETED TRIPLE SEARCH.
POP P,D ;THE BRACKETED ITEM NUMBER
P3: POP P,B ;THE VALUE
TLNE FLAG,BOUND⊗VALPOS ;IF VALUE IS A BOUND ITEMVAR, THEN
XCT MOVEB(FRTAB) ;GET THE SATISFIER FROM THE TABLE.
TRZ B,BNDFOR ;TURN OFF "BOUND"BIT
JUMPN B,.+2
TLO FLAG,BINDING⊗VALPOS ;VALUE IS "ANY"
PUSH FPD,B
TLNE FLAG,BINDING⊗VALPOS ;IS ENTRY UNBOUND?
GLOB <
JRST P3A ;NOT BOUND
TLNE FLAG,GLBSRC ;GLOBAL SEARCH?
CAIL B,GBRK ;WITH LOCAL ITEM?
JRST P3OK
ERR <GLOBAL SEARCH WITH LOCAL ITEM>,1
SKIPA
P3A:
>;GLOB
SETZM B ;ZERO UNBOUND ENTRY
P3OK:
LSHC B,-ITLEN ;MAKE UP MASK IN C.
P2: POP P,B
TLNE FLAG,BOUND⊗OBJPOS
XCT MOVEB(FRTAB)
;;#JL# BY JRL 10-4-72 SETS NOT POT BOUND
TLNN FLAG,SETOP ;BNDFOR ONLY FOR ITEMS
TRZ B,BNDFOR
JUMPN B,.+2
TLO FLAG,BINDING⊗OBJPOS ;OBJECT IS ANY.
PUSH FPD,B
TLNE FLAG,BINDING⊗OBJPOS
GLOB <
JRST P2A ;UNBOUND ENTRY
TLNE FLAG,SETOP ;A SET OPERATION?
JRST P2OK ;YES.
TLNE FLAG,GLBSRC ;GLOBAL SEARCH?
CAIL B,GBRK ;GLOBAL ITEM?
JRST P2OK ;ALL OK.
ERR <GLOBAL SEARCH WITH LOCAL ITEM>,1
SKIPA
P2A:
>;GLOB
SETZM B
P2OK:
LSHC B,-ITLEN
P1: POP P,B ;ATTRIBUTE
TLNE FLAG,BOUND⊗ATTPOS
XCT MOVEB(FRTAB)
TRZ B,BNDFOR
JUMPN B,.+2
TLO FLAG,BINDING⊗ATTPOS ;ATTRIB IS ANY
PUSH FPD,B
TLNE FLAG,BINDING⊗ATTPOS
GLOB <
JRST P1A
TLNE FLAG,GLBSRC
CAIL B,GBRK
JRST P1OK
ERR <GLOBAL SEARCH WITH LOCAL ITEM>,1
SKIPA
P1A:
>;GLOB
SETZM B
P1OK:
LSHC B,-ITLEN
SETZM INDEX4(FRTAB)
PUSH FPD,C ;THE MASK OF A-O-V
;UNBOUND PORTIONS OF THE MASK ARE 0
PUSH FPD,[-1] ;INITIAL -TT1(FPD)
PUSH FPD,[0] ;INITIAL -T2(FPD)
TLNE FLAG,SETOP ;DON'T COMPUTE ROUTINE NAME FOR SET SEARCH
JRST STSRCH
HRRI FLAG,0
TLNE FLAG,BINDING⊗ATTPOS
TRO FLAG,1
TLNE FLAG,BINDING⊗OBJPOS
TRO FLAG,2
TLNE FLAG,BINDING⊗VALPOS
TRO FLAG,4
STSRCH:
PUSH FPD,FLAG ;SAVE THE ROUTINE NAME.
PUSH FPD,UUO1(USER) ;SAVE RETURN ADDRESS.(on success)
HRLM D,(FPD) ;SAVE BRACKETED ITEM # IN LH.
JRST (LPSA) ;ALL DONE.
DSCR FOREACH STATEMENT INTERPRETER
THERE ARE SEVERAL ROUTINES IN THIS SECTION:
FORGO -- CALLED TO INITIALIZE A FOREACH STATEMENT.
RECORDS FAILURE ADDRESS.
RECORDS COUNT AND ADDRESSES OF FREE ITEMVARS.
FRGO -- TO INITIALIZE A PART OF LEAP CORE (JUST LIKE THE
LEABOT(USER) AREA) TO USE AS A SEARCH CONTROL
BLOCK.
FDONE -- WHEN THE OUTERMOST SEARCH IN THE FOREACH STAT.
FAILS, THIS IS CALLED. IT MERELY TAKES THE
FAILURE EXIT FROM THE FOREACH STATEMENT.
FDONS -- USED BY THE "DONE" CONSTRUCT (OR BY A "GO TO")
WHEN EXITING FROM INSIDE A FOREACH STATEMENT -- THE
IDEA IS TO BACK UP THE NESTING OF FOREACH SEARCHES BY
ONE, AND DO SOME BOOKEEPING.
FRPOP -- CALLED AT END OF SEARCH SPECIFICATIONS IN FOREACH
OR WHEN PREPARING FOR A BOOLEAN EXPRESSION INSIDE
A FOREACH SPECIF. THIS COPIES CURRENT SATISFIER
VALUES INTO THEIR REAL USER CORE ADDRESSES (AS RECORDED
BY FORGO).
FRFAL -- WHEN BOOLEAN FAILS WITHIN FOREACH. FIRE UP SEARCHES AGAIN
DOAG -- CALLED AT THE BOTTOM OF THE FOREACH LOOP. CAUSES
THE SEARCHES TO BE FIRED UP TO FIND THE NEXT GROUP OF
SATISFIERS.
FOREC -- MAIN CALL TO START A TRIPLE SEARCH, AS SPECIFIED
IN THE FOREACH SPECIFICATION. A,O, AND V ARE ON THE
STACK.
LD1,LD2,LD3 -- CALLED BY "DERIVED SETS" INSIDE A FOREACH SPEC.
SPECIAL ADJUSTMENTS ARE MADE TO THE STACK (TO REORDER
OPERANDS).
⊗;
LD3: MOVE B,(P) ;IN IS O,V,X
EXCH B,-2(P)
JRST LD22
LD2: MOVE B,(P) ;IN IS A,V,X
LD22: EXCH B,-1(P) ;MAKE IT A⊗X≡V
MOVEM B,(P)
;COMPILER HAS FIXED UP THE BITS
;CORRECTLY ALREADY.
LD1:
↑FOREC: MOVE FRTAB,FRLOC(USER); CURRENT SCB
SKIPE A,RUNNER ;ARE THERE PROCESSES?
MOVE FRTAB,CURSCB(A) ;THEN LOAD FROM PVAR AREA
SETZB LPSA,D ;MAIN FOREACH SPECIFICATION PROCESSOR.
GLOB <
NOSEC ;FAKE IT BACK. YOU ARE NOT
;CONSIDERED "ENTERED" WHEN RUNNING
;FOREACHES......
>;GLOB
ADD FLAG,INDEX4(FRTAB)
SETZM INDEX4(FRTAB)
JSP LPSA,FORSET ;SET UP THE SEARCH CONTROL BLOCK.
GO: ;LOOP BACK TO HERE TO DO SEARCHES.
GLOB <
MOVE FLAG,-1(FPD) ;PICK UP ROUTINE NAME.
MOVEI TABL,(USER)
TLNE FLAG,GLBSRC ;IF GLOBAL, THEN
MOVEI TABL,GLUSER ;REARRANGE.
JUMPL FLAG,BRACK ;AND GO IF BRACKETED TRIPLE SEARCH.
>;GLOB
NOGLOB <
SKIPG FLAG,-1(FPD) ;PICK UP ROUTINE NAME.
JRST BRACK ;BRACKETED SEARCH
>;NOGLOB
PUSHJ P,@SEROUT(FLAG) ;CALL THE ROUTINE.
JRST FAIL ;IT FAILED IF IT CAME HERE.
;BACK UP THE SEARCH TO NEXT OUTER.
SUCC: MOVEM FPD,FPDP(FRTAB) ;SAVE PUSH-DOWN POINTER
MOVE FPD,(FPD) ;RETURN ADDRESS (LEFT HALF HAS STUFF)
JRST (FPD) ;RETURN
;THIS DOES NOT RETURN THROUGH
;"LEAV".
GLOB <
;HENCE WE SEE THAT YOU ARE REALLY NOT "ENTERED"
;WHEN EXECUTING THIS CODE.
>;GLOB
FAIL: MOVE FLAG,-1(FPD) ;THE CONTROL WORD.
SKIPGE A,-SETP(FPD) ;IF SET NEEDS RECLAIMING
TLNN FLAG,SETOP ;WAS THIS A SET?
JRST FAIGO
MOVE B,FP1(USER) ;PREPARE TO RECLAIM TEMP SET.
HLRZ C,(A)
HRRZM B,(C) ;PUT IN DOWN POINTER.
HRRM A,FP1(USER) ;AND UPDATE FREE LIST.
FAIGO: SUB FPD,[XWD LENFPD,LENFPD]
JRST GO ;USE THE NEXT HIGHER ROUTINE.
BRACK: ;IF BRACKETED TRIPLE SEARCH.
PUSHJ P,@SEROUT(FLAG) ;CALL THE ROUTINE.
JRST FAIL ;FAIL....
HLRZ B,(A) ;A POINTS TO THING FOUND.
BRACKN B ;IS THIS A BRACKETED TRIPLE?
JRST [HRRZ FLAG,-1(FPD) ;NO -- GET CONTROL WORD AGAIN.
JRST BRACK] ;AND TRY AGAIN.
HRRZ B,(B) ;THIS IS THE ITEM ## BRACKET.
HLRZ C,(FPD) ;THIS IS THE LOCAL NUMBER
;FOR THE BRACKETED #
DPB B,MC(FRTAB) ;STORE AWAY THE LOCAL.
JRST SUCC ;AND WE SUCCEEDED.
;JRST TO DOAG, FRFAL
↑DOAG:
MOVE FRTAB,FRLOC(USER) ;CURRENT SCB
SKIPE A,RUNNER ;ARE THERE PROCESSES?
MOVE FRTAB,CURSCB(A) ;LOAD FROM PVAR AREA
HRRE A,SCNT(FRTAB) ;NUMBER OF SATS TO SAVE
MOVEI B,SATIS+1(FRTAB)
DOAGLP: AOJG A,FRFAL2 ;THROUGH GETTING CURRENT VALS?
SKIPG C,(B) ;WAS THIS A ? LOCAL ALREADY BOUND?
AOJA B,DOAGLP ;YES.
HLRZM C,OLDSAT-SATIS-1(B) ;DEPOSIT LATEST SATISFIER
AOJA B,DOAGLP ;LOOP
↑FRFAL:
MOVE FRTAB,FRLOC(USER) ;CURRENT SCB
SKIPE A,RUNNER ;ARE THERE PROCESSES?
MOVE FRTAB,CURSCB(A) ;LOAD FROM PVAR AREA
FRFAL2: MOVE FPD,FPDP(FRTAB) ;RESTORE PUSHDOWN POINTER.
JRST GO ;CALL THE RIGHT ROUTINE.
;JRST TO FORGO
↑FORGO:
SKIPN B,SCBCHN(USER) ;FREE SCB'S?
JRST [PUSH P,TAC1 ;CORGET WILL DESTROY
LPCOR (<FRCHLEN>) ; NO GO GET ONE.
POP P,TAC1 ;RESTORE IT
JRST HAVSCB]
HRRZ A,SCBLNK(B) ;ADDRESS NEXT FREE SCB
MOVEM A,SCBCHN(USER) ;UPDATE FREE SCB CHAIN
HAVSCB: HRRZ A,FRLOC(USER) ;DYNAMIC NESTING SCB
SKIPE D,RUNNER
HRRZ A,CURSCB(D)
HRL A,(P) ;ADDRESS SCB POINTER
MOVEM A,SCBLNK(B) ;DYNAMIC SCB CHAIN
POP P,A ;ADDRESS SCB POINTER
MOVEM B,(A) ;PUT POINTER IN.
HRL B,A
MOVEM B,FRLOC(USER) ;HANDLE TO CURRENT SCB
SKIPE D,RUNNER
MOVEM B,CURSCB(D)
MOVEI FP,FREND ;IN LINE CALL TO FRGO
FRGO:
MOVEI A,FPDL-1(B) ;PUSHDOWN LIST.
HRLI A,-FPDLEN ;AND LENGTH.
HRRI C,SATIS(B) ;SATISFIER LIST.
HRLI C,(<HLRZ A,(A)>)
MOVEM C,MOVEA(B) ;THIS IS THE "UPDATE "A" INSTRUCTION".
HRLI C,(<HLRZ B,(B)>)
MOVEM C,MOVEB(B) ;AND FOR B.
HRLI C,(<POINT 12,(C),17>)
MOVEM C,MC(B) ;BYTE POINTER FOR
;PUTTING AWAY SATISFIERS.
PUSH A,[XWD 0,-1] ;TO CALL FDONE WHEN ALL DONE.
PUSH A,(TAC1) ;THIS IS THE JUMP OUT OF THE FOREACH.
;TAC1 THAT IS FRTAB CONTAINS ADDRESS OF SATISFIER INFO BLOCK FROM CALLER
MOVEM A,FPDP(B) ;AND SAVE THE PUSH-DOWN POINTER.
JRST (FP)
FREND: ADDI TAC1,1 ;INCREMENT OVER JRST WORD.
MOVEI D,SATIS+1(B) ;BEGINNING OF SATISFIER TABLE.
MOVN A,(TAC1) ; - COUNT OF LOCALS IN THIS LIST.
MOVEM A,SCNT(B) ;KEEP TRACK FOR THE POPPING OFF.
LOP: ADDI TAC1,1 ;THIS COUNTS UP!
AOJG A,LEAV ;DONE, BY GOOOLLY
MOVE C,(TAC1) ;THE LOCAL WORD
TLNN C,CDISP ;A DISPLAY NEEDED?
JRST NODISP ;NO.
LDB B,[POINT 4,(C),17] ;PICK UP DISPLAY DIFFERENCE
MOVEI LPSA,(RF) ;THE CURRENT DISPLAY
LPDISP: MOVE LPSA,1(LPSA) ;BACK THE STATIC LINK
SOJG B,LPDISP ;COUNT DOWN DIFFERENCE
ADD LPSA,(C) ;ADD THE DISPLACEMENT
TLNE C,20 ;REFERENCE PARAMETER?
MOVE LPSA,(LPSA) ;YES
JRST HAVEAD
NODISP: MOVEI LPSA,@C ;MUCH EASIER
HAVEAD: TLNN C,MPPAR ;A ? PARAMETER?
JRST CALPOT ;NO.
MOVE B,(LPSA)
TLZE B,20 ;BOUND?
MOVEI LPSA,(B) ;NO.
CALPOT:
HRRZ B,(LPSA) ;PICK UP CURRENT VALUE
MOVEM B,OLDSAT-SATIS-1(D) ;SAVE CURRENT VALUE FOR BACKUP
TLNE C,POTUNB ;A POTUNB LOCAL(?)
CAIN B,UNBND ;AND UNBOUND
CAIA
TRO B,BNDFOR ;MARK AS BOUND ON ENTRY
HRL LPSA,B ;GET CURRENT VALUE IF BOUND
MOVEM LPSA,(D) ;SAVE IN SATIS TABLE
AOJA D,LOP ;LOOP
;FDONE WHEN ALL TESTS EXHAUSTED END FOREACH
FDONE: MOVE FP,(FPD) ;RETURN ADDRESS.
;RESTORE LAST SUCCESSFUL SATISFIER GROUP
HRRE A,SCNT(FRTAB)
MOVEI B,SATIS+1(FRTAB)
LPDONE: AOJG A,RESTSCB
SKIPG C,(B) ;A ?LOCAL BOUND ON ENTRY?
AOJA B,LPDONE ;YES.
MOVE D,OLDSAT-SATIS-1(B) ;PICK UP LATEST SATISFIER
MOVEM D,(C) ;STORE INTO CORE
AOJA B,LPDONE
RESTSCB:
PUSHJ P,SCBRES ;RESTORE SCB TO FREE LIST
SUB P,X11 ;PAST FOREACH RETURN ADDRESS
JRST (FP) ;JUMP OUT OF FOREACH STATEMENT.
FDONS: MOVE FRTAB,FRLOC(USER);CURRENT SCB
;; #KP# BY JRL (11-28-72) FOLLOWING TWO INSTRS USED AND THUS DESTROYED AC A
SKIPE D,RUNNER
MOVE FRTAB,CURSCB(D)
PUSHJ P,SCBRES ;RESTORE SCB TO FREE LIST
MOVE FPD,FPDP(FRTAB) ;WE ARE ABOUT TO LEAVE, SO MAKE
FDX: MOVE D,-1(FPD) ;LOOK AT CONTROL WORD.
SKIPGE LPSA,-SETP(FPD) ;IF SET NEEDS RECLAIMING
TLNN D,SETOP ;THEN DO SO
JRST FDY
MOVE B,FP1(USER) ;PREPARE TO RECLAIM SET.
HLRZ C,(LPSA)
HRRZM B,(C)
HRRM LPSA,FP1(USER) ;DONE.
FDY: CAIN D,-1 ;THIS IS THE LAST.
POPJ P, ;DONE
SUB FPD,[XWD LENFPD,LENFPD]
JRST FDX ;AND GO FOR MORE.
SCBRES: ;RECLAIM AN SCB
;; #KP# THIS ROUTINE FORMERLY USED AC A INSTEAD OF PNT THUS
;; DESTROYING VALUE OF EXPRESSION RETURNED FROM FOREACH
HLR PNT,FRLOC(USER) ;ADDRESS OF SCB POINTER
SKIPE D,RUNNER
HLR PNT,CURSCB(D)
SETZM (PNT) ;ZERO IT
HRRZ PNT,FRLOC(USER) ;ADDRESS THIS SCB
SKIPE D
HRRZ PNT,CURSCB(D)
MOVE B,SCBLNK(PNT) ;ADDRESS PREVIOUS SCB
HLL B,SCBLNK(B) ;GET ADDR SCB POINTER
MOVEM B,FRLOC(USER) ;POP FOREACH
SKIPE D
MOVEM B,CURSCB(D)
MOVE B,SCBCHN(USER) ;WILL ADD TO FREE SCB CHAIN
MOVEM B,SCBLNK(PNT) ;ADD TO FREE LIST
MOVEM PNT,SCBCHN(USER);UPDATE FREE LIST
POPJ P, ;RETURN
;PUSHJ TO FRPOP
↑FRPOP: MOVE FRTAB,FRLOC(USER);CURRENT SCB
SKIPE D,RUNNER
MOVE FRTAB,CURSCB(D)
HRRE A,SCNT(FRTAB) ;COUNT OF LOCALS.
;PICKED UP WITH HRRE SINCE THE
;DEPOSITS OF SATISFIERS FOR "ANY" WILL BE WRONG.
MOVEI B,SATIS+1(FRTAB) ;START OF SATISFIERS.
LOPS: AOJG A,CPOPJ ;LOOP UNTIL ALL IN CORE.
SKIPG C,(B)
AOJA B,LOPS
HLRZM C,(C) ;STORE LEFT HALF IN CORE.
AOJA B,LOPS
;PUSHJ TO CORPOP
↑CORPOP: MOVE FRTAB,FRLOC(USER);CURRENT SCB
SKIPE D,RUNNER
MOVE FRTAB,CURSCB(D)
HRRE A,SCNT(FRTAB) ;COUNT OF LOCALS
MOVEI B,SATIS+1(FRTAB) ;ADDR FIRST LOCAL
LOPCP: AOJG A,CPOPJ ;THROUGH?
SKIPG D,(B) ;POT UNB ACTUALLY BOUND
AOJA B,LOPCP ;YES
HRL D,(D) ;THE CURRENT VALUE
MOVEM D,(B) ;BACK INTO SATIS TABLE
AOJA B,LOPCP ;CONTINUE
DSCR ? LOCAL STACK ROUTINES,STK4LC,STK4VL
⊗
STK4LC: ;STACK FOREACH ? LOCAL AS PARM TO MATCHING PROCEDURE
;JRST'ED TO
MOVE FRTAB,FRLOC(USER)
SKIPE A,RUNNER ;PROCESSES AROUND?
MOVE FRTAB,CURSCB(A) ;GET FRCH TABLE FROM PROCESS VARIABLE AREA
POP P,A ;LOCAL NUMBER
MOVEI B,SATIS(FRTAB) ;START OF SATISFIER TABLE
ADDI B,(A) ;ADDRESS THIS SATISFIER
SKIPL C,(D) ;BOUND ON ENTRY?
JRST STKREF ;NO.
XCT MOVEA(FRTAB) ;YES GET CURRENT VALUE
TRZ A,BNDFOR ;TURN OFF "BOUND ON ENTRY" BIT
PUSH P,A ;LEAV ON STACK
JRST LEAV
STKREF: HRLI C,20 ;MARK AS UNBOUND
PUSH P,C ;STACK ADDRESS OF LOCAL
JRST LEAV
STK4VL: ;FOREACH SEARCHES STACK LOCAL NUMBER OR VALUE
;JRST'ED TO
MOVE FRTAB,FRLOC(USER)
SKIPE A,RUNNER
MOVE FRTAB,CURSCB(A)
POP P,D ;THE DISPATCH INCREMENT AND TYPE BITS
MOVE A,(P) ;LOCAL NUMBER
MOVEI B,SATIS(FRTAB) ;ADDRESS SATISFIER TABLE
ADDI B,(A) ;ADDRESS THIS LOCAL
SKIPG C,(B) ;BOUND?
JRST STK4V2 ;YES
TLZA D,BOUND⊗ATTPOS!BOUND⊗OBJPOS!BOUND⊗VALPOS
STK4V2: AND D,[XWD BOUND⊗ATTPOS!BOUND⊗OBJPOS!BOUND⊗VALPOS,0]
ADDM D,INDEX4(FRTAB)
JRST LEAV
DSCR BNDTRP- BINDING FORM OF BOOLEAN AOO≡V
Top three elements of stack are A, O, and V. If the
element is being bound the corresponding bit in FLAG is on and
the stack entry contains the address of the itemvar being bound.
ANY is represented by the stack entry being zero.
⊗
BNDTRP: ;JRST'ED TO
MOVE FRTAB,LEABOT(USER) ;GET STATIC SCB
SETZM SATIS+1(FRTAB) ;CLEAR SATISFIER ENTRIES
SETZM SATIS+2(FRTAB)
SETZM SATIS+3(FRTAB)
TLNN FLAG,BINDING⊗ATTPOS ;ATTRIBUTE UNBOUND?
JRST OPOS ;NO.
SKIPG B,-2(P) ;GET ATTRIBUTE ITEMVAR.
;POTUNB BIT IS SIGN BIT
JRST [TLZ B,POTUNB ;A ?ITMVR
MOVE C,(B)
CAIN C,UNBND ;BOUND?
JRST .+1 ;NO.
TLZ FLAG,BINDING⊗ATTPOS ;NO WE'RE NOT BINDING IT
MOVEM C,-2(P) ;ACTUAL VALUE
JRST VPOS]
MOVEI C,1 ;FIRST SATISFIER
HRRZM B,SATIS+1(FRTAB) ;SAVE ADDR OF ATTRIB. ITMVR
HRRZM C,-2(P) ;FIRST SATISFIER IS ATTRIB
OPOS:
TLNN FLAG,BINDING⊗OBJPOS ;OBJECT UNBOUND?
JRST VPOS ;NO.
SKIPG B,-1(P) ;OBJECT ITEMVAR
JRST [TLZ B,POTUNB ;A ?ITMVR
MOVE C,(B)
CAIN C,UNBND ;ACTUALLY BOUND?
JRST .+1 ;NO.
TLZ FLAG,BINDING⊗OBJPOS
MOVEM C,-1(P)
JRST VPOS]
MOVEI C,1 ;ASSUME SAME AS ATTRIB
CAMN B,SATIS+1(FRTAB) ;IS IT REALLY?
JRST STOBJ ;YES
MOVEI C,2 ;ATTRIB≠OBJECT ITEMVAR
HRRZM B,SATIS+2(FRTAB) ;SAVE ADDR OF OBJECT ITMVAR
STOBJ: MOVEM C,-1(P) ;SATIS NO. FOR OBJECT
VPOS:
TLNN FLAG,BINDING⊗VALPOS ;VAL UNBOUND?
JRST SET.UP
SKIPG B,(P) ;VAL = ANY?
JRST [TLZ B,POTUNB
MOVE C,(B)
CAIN C,UNBND
JRST .+1
TLZ FLAG,BINDING⊗VALPOS
MOVEM C,(P)
JRST SET.UP]
MOVEI C,1 ;ASSUM SAME AS ATTRIB ITMVR
CAMN B,SATIS+1(FRTAB) ;IS IT
JRST STVAL ;YES, THE SAME
MOVEI C,2 ;SAME AS OBJECT ITMVR?
CAMN B,SATIS+2(FRTAB) ;
JRST STVAL ;YES, THE SAME
MOVEI C,3 ;DIFFERENT THAN THE OTHERS
HRRZM B,SATIS+3(FRTAB) ;SAVE ADDR VALUE ITMVR
STVAL: MOVEM C,(P) ;SATIS NO. FOR VALUE
SET.UP:
JSP LPSA,FORSET ;SET UP MASK,SCB ETC
;ALSO DOES BINDING BITS FOR "ANY"
PUSHJ P,@SEROUT(FLAG) ;DO SEARCH
JRST RETNO ;RETURN FALSE
SKIPE A,SATIS+1(FRTAB) ;FIRST SATIS USED?
HLRZM A,(A) ;YES.
SKIPE A,SATIS+2(FRTAB)
HLRZM A,(A)
SKIPE A,SATIS+3(FRTAB)
HLRZM A,(A)
JRST RETYES ;RETURN TRUE
;SOME VARIOUS BOOLEANS
ISIT: ;JRST HERE FOR A⊗O≡V ?
MOVE FRTAB,LEABOT(USER)
JSP LPSA,FORSET ;GO GET THINGS SET UP
;; FORSET HAS CHANGED THE RH OF FLAG FOR APPROPRIATE SEARCH
PUSHJ P,@SEROUT(FLAG);CALL ROUTINE.
RETNO: TDZA A,A ;FAILED
RETYES: SETOM A ;SUCCEEDED.
;RESULT LEFT IN REGISTER 1.
JRST LEAV
BRITM: ;JRST HERE FOR BRACKETED ITEM
;TO BE LEFT ON STACK.
MOVE FRTAB,LEABOT(USER)
JSP LPSA,FORSET ;GO START THINGS.
;; FORSET HAS STACKED ARGS AND COMPUTED ROUTINE NAME
BRGO: MOVE FLAG,-1(FPD) ;ROUTINE NAME.
PUSHJ P,@SEROUT(FLAG);CALL IT.
JRST [PUSH P,[NIC]
JRST LEAV]
HLRZ B,(A) ;VALUE POINTER.
BRACKN B ;BRACKETED?
JRST BRGO ;NO
HRRZ B,(B) ;YES -- THIS IS THE ITEM.
PUSH P,B ;ON STACK -- RESULT IS ITEM NUMBER.
JRST LEAV ;DONE.....
DSCR DERIVED SETS -- NOT IN FOREACH SPECIFICATIONS.
THESE ROUTINES COMPUTE DERIVED SETS. THEY CALL THE SEARCH
ROUTINES ABOVE, AFTER SETTING UP THE "FIXED" SEARCH CONTROL
BLOCK TO RELECT THE PARTICULAR SEARCH.
⊗;
; A⊗O
D1: MOVE FRTAB,LEABOT(USER)
PUSH P,[1] ;FOR VALUE -- RESULT.
JRST DOIT ;READY TOGO
; O≡V
D3: MOVE FRTAB,LEABOT(USER)
MOVEI A,1
EXCH A,-1(P)
JRST D2DO
; A'V
D2: MOVE FRTAB,LEABOT(USER)
MOVEI A,1
D2DO: EXCH A,(P)
PUSH P,A ;CHANGE ORDER OF ARGS.
DOIT:
JSP LPSA,FORSET
PUSH P,[0] ;THE SET WE WILL ACCUMULATE.
AGS: PUSHJ P,@SEROUT(FLAG) ;CALL THE SEARCH
JRST [HLRZ A,(P) ;FAILED, AND DONE!
MOVNS A ;CHANGE COUNT TO NEGATIVE
;TO INDIC. TEMP.
HRLM A,(P)
JRST LEAV]
HLRZ A,SATIS+1(FRTAB);RESULT IN FIRST SATISFIER
MOVEI TAC1,(P) ;PLACE OF SET
GLOB <
PUSH P,TABL
TLZ FLAG,GLBSRC ;ENTY NEEDS TO KNOWS....
>;GLOB
PUSH P,A ;ITEM FOR ENTY.
PUSHJ P,ENTY ;IN PUTIN
GLOB <
POP P,TABL
>;GLOB
MOVE FRTAB,LEABOT(USER) ;SINCE ENTY DESTROYED TAC1
MOVE FLAG,-1(FPD)
JRST AGS ;LOOP UNTIL DONE.
DSCR MAKE AND ERASE
THESE ARE THE ROUTINES TO MAKE AND ERASE ASSOCIATIONS IN THE
ASSOCIATIVE STORE. THE BIGGEST HAIR IN THESE ROUTINES HAS
TO DO WITH MULTIPLE VALUES. "MAKE" MAY HAVE TO EXPAND
A SINGLE ASSOCIATION INTO A MULTIPLE VALUE CONFIGURATION,
AND "ERASE" MAY HAVE TO CONTRACT IT.
MAKE AND ERASE ARE BOTH CALLED WITH THE THREE TOP OF STACK
ELEMENTS BEGIN THE ATTRIBUTE, OBJECT, AND VALUE PASSED
AS ARGUMENTS.
MAKE AND ERASE HAVE A "BREAKPOINT" FACILITY, FOR ACTIVATING
A SAIL PROCEDURE EACH TIME AN ASSOCIATION IS MADE OR ERASED.
THE A, O, AND V ARE PASSED BY VALUE IN THE STACK TO THE
BREAKPOINT ROUTINE.
PROBLEMS OCCUR WHEN AN ASSOCIATION IS ERASED WHICH IS POINTED
TO BY SOME POINTER IN THE FOREACH SEARCH TABLES. WE SHOULD
PROBABLY SEARCH ALL ACTIVE SCBS FOR SUCH POINTERS AND GIVE A WARNING
BUT EVEN THIS WAY WE COULD NOT FIND POINTERS IN OTHER JOBS SHARING
A GLOBAL STRUCTURE OR POINTERS IN AN ERASE SCB WHOSE ERASE WAS
INTERRUPTED BY A ERASE-BREAKPOINT.
MAKE -- CALLED WITH PUSHJ.
ERASE -- JRST TO IT; IT WILL JRST TO LEAV.
BMAKE -- JRST TO IT; IT WILL JRST TO LEAV. (BRACKETED TRIPLE MAKE).
⊗;
;PUSHJ TO MAKE
; ON EXIT, "PNT" MUST POINT TO THE ASSOCIATION CREATED.
MAKE:
SKIPE A,-1(P) ;VALUE "ANY"?
CAIN A,UNBND ;OR VALUE UNBOUND?
JRST ERRMAK
SKIPE A,-2(P) ;OBJECT "ANY"?
CAIN A,UNBND ;OR OBJECT UNBOUND?
JRST ERRMAK
SKIPE A,-3(P) ;ATTRIB "ANY"?
CAIN A,UNBND ;ATTRIB UNBOUND?
ERRMAK: ERR <MAKE WITH UNBOUND ITEM>,1
GLOB <
WRITSEC ;ENTER A POINTER-DIDLING AREA!
TLNN FLAG,GLBSRC ;GLOBAL MAKE?
JRST LOCMAK ;NO.
;; CAN THE FOLLOWING TESTS BE EFFICIENTLY BE MERGED WITH TESTS ABOVE?
MOVEI A,GBRK ;GLOBAL LOCAL BREAK
CAMG A,-1(P) ;VALUE GLOBAL?
CAML A,-2(P) ;OBJECT LOCAL?
JRST .+2
CAML A,-3(P) ;ATTRIB LOCAL?
ERR <GLOBAL MAKE WITH LOCAL ITEM>,1
LOCMAK:
>;GLOB
SKIPE C,MKBP(USER) ;MAKE BREAK-POINT?
PUSHJ P,LPBRK1 ;GO TO A BREAKPOINT !
GLOB <
SKIPN FP,FP2(TABL) ;WE WILL CERTAINLY NEED SOME FRESS.
PUSHJ P,FP2DON ;GET SOME.
>;GLOB
NOGLOB<
MOVE FP,FP2(TABL)
>;NOGLOB
MOVE PNT,FP ;THIS IS THE ONE WE WILL USE.
SETZM C ;FOR MAKING UP THE MAGIC WORD.
MOVE B,-2(P) ;OBJECT.
LSHC B,-ITLEN
MOVE B,-3(P) ;ATTRIBUTE
LSHC B,-ITLEN ; A-O-0 IS IN C.
HASH (D,<-3(P)>,<-2(P)>)
SKIPN A,(D) ;ANY THING THERE?
JRST GOM ;NO.
AG: MOVE B,1(A) ;GET A-O-V OF THIS ASSOC
TRZ B,7777 ;A-0
CAMN B,C ;SAME AS THE ONE WE ARE PUTTING IN?
JRST DONE ;YES -- MODULO MULTIPLE HITS.
MOVE D,A ;REMEMBER WHO POINTS TO US.
HRRZ A,(A) ;GO DOWN CONFLICT LIST.
JUMPN A,AG ;GO UNTIL END
GOM: SKIPN FP,(FP) ;NOW TACK ONE WORD ONTHE END.
PUSHJ P,FP2DON
SETZB (PNT) ;ZERO FIRST WORD OF ASS. CELL.
HRRM PNT,(D) ;LINK CONFLICT.OR MULTIPLE HIT LIST
IOR C,-1(P) ;GET VALUE THERE
MOVEM C,1(PNT) ;AND STORE A-O-V
MOVE C,-1(P) ;GET VALUE AGAIN.
ADD C,INFOTAB(TABL) ;NEED TO UPDATE VALUE LINK
HLRZ D,(C) ;OLD ONE
HRLM D,(PNT) ;STORE IN VALUE SPOT
HRLM PNT,(C) ;AND UPDATE INFO TABLE.
MOVEM FP,FP2(TABL) ;SAVE NEW FREE POINTER.
OUT111: SUB P,[XWD 4,4]
JRST @4(P) ;RETURN, AFTER ADJUSTING STACK.
OUT1A: MOVE PNT,A
JRST OUT111 ;MUST HAVE PNT POINTING
;TO THING WE MADE.
DONE: MOVE B,1(A) ;AT LEAST A AND O MATCH TO GET HERE.
TRNN B,7777 ;MULTIPLE VALUES?
JRST MULVAL ;YES
ANDI B,7777
CAMN B,-1(P) ;COMPARE WITH SPECIFIED VALUE
JRST OUT1A ;IT IS ALREADY THERE!!!
SKIPN FP,(FP) ;MUST NOW MAKE A MULTIPLE VALUE GUY
PUSHJ P,FP2DON
MOVE LPSA,FP ;ADDRESS ONE-WORD FREE
EXCH LPSA,PNT ;USE OLDER FREE FIRST
HRL A,(A) ;XWD CONF.LIST,,NEW MULT HIT LIST
MOVSM A,(LPSA) ;STORE XWD MH-LIST,,CONF LIST
MOVEM C,1(LPSA) ;STORE A-0 MH HEADER
HRRM LPSA,(D) ;LINK INTO CONFLICT LIST
HRRZ D,A ;FIRST ITEM ON CONFLICT LIST
JRST GOM
MULVAL: HLRZ A,(A) ;PICK UP POINTER TO MULT. VALS.
IN1: MOVE B,1(A) ;PICK UP A-O-V
ANDI B,7777 ;SAVE ONLY VALUE
CAMN B,-1(P) ;THE RIGHT VALUE?
JRST OUT1A ;YES -- IT'S THERE
MOVE D,A ;BACK-POINTER
HRRZ A,(A) ;GET NEXT POINTER
JUMPE A,GOM ;PUT ON END OF MH LIST
JRST IN1 ;LOOP UNTIL FOUND OR MH LIST EXHAUSTED
;JRST TO BMAKE
BMAKE: ;BRACKETED MAKE.......;;
PUSHJ P,MAKE ;GO MAKE IT..
HLRZ A,(PNT) ;VALUE POINTER
BRACKP A ;IS IT ALREADY A BRACKETED?
JRST INALREADY ;YES
GLOB <
;MAKE HAS PUT JOB INTO WRITING SECTION
SKIPN FP,FP1(TABL) ;ONE-WORD FREES.
PUSHJ P,FP1DON ;NONE YET, GET SOME.
>;GLOB
NOGLOB <
MOVE FP,FP1(TABL) ;ONE-WORD FREES.
>;NOGLOB
MOVEI C,(FP)
SKIPN FP,(FP)
PUSHJ P,FP1DON ;OUT OF FREE STORAGE.
HRRM FP,FP1(TABL)
HRLM A,(C) ;OLD VALUE LIST
TRC C,BRABIT ;TURN IT ON.(LOGICALLY)
HRLM C,(PNT)
PUSH P,PNT ;SAV ADDR OF IT
NOGLOB <
HRLI FLAG,BRKITM ;SO NEW WILL INIT TYPE
> ;NOGLOB
GLOB <
TLZ FLAG,-1≠GLBSRC ;DON'T DESTROY GLOBAL BIT
TLO FLAG,BRKITM ;ITEM TYPE IS BRACKETED ITEM
> ;GLOB
PUSHJ P,NEWX ;GET A NEW ITEM.....
MOVE PNT,(P)
EXCH PNT,-1(P)
POP P,B ;ITEM NUMBER.
HLR C,(PNT) ;THE BRACKET NODE
TRC C,BRABIT
HRRM B,(C) ;PUT ITEM NUMBER IN BRACKET NODE
ADD B,DATAB(TABL) ;PREPARE TO MAKE VALUE EENTRY
MOVEM PNT,(B) ;POINTER TO ASSOC
JRST LEAV
INALREADY:
HRRZ B,(A) ;ITEM NUMBER....
PUSH P,B
JRST LEAV
;PUSHJ, TO ERASE
ERASE:
GLOB <
WRITSEC ;ANOTHER POINTER DIDDLING AREA !!
>;GLOB
POP P,PNT ;SAVE RETURN ADDRESS.
JSP LPSA,NOFOR ;IN LINE CALL
PUSH P,PNT ; ";" ADDED 5-3 DCS
TRY: MOVE FLAG,-1(FPD) ;ROUTINE NAME.
PUSHJ P,@SEROUT(FLAG);GET THE RIGHT SEARCH
POPJ P, ;DONE... (IT FAILED)
SKIPE C,ERBP(USER) ;ERASE BREAK-POINT?
PUSHJ P,LPBRK ;A LEAP BREAK POINT !!!
HRRZ B,1(A) ;A POINTS TO ASS. CELL
TRZ B,770000 ;NOW WE HAVE THE VALUE
ADD B,INFOTAB(TABL) ;NONO
GOE: HLRZ C,(B) ;VALUE LINK.
BRACKP C ;TEST FOR BRACKETED TRIPLE
JFCL ;MACROS FORCE ONE OCCASIONALLY TO PARANOIA
CAIN C,(A) ;THE VERY SAME?
JRST YESE ;WE HAVE IT
MOVE B,C ;REMEMBER WHERE WE CAME FROM
JUMPN B,GOE
ERR <DRYROT -- ERASE1>;ASSOCIATION NOT ON VALUE LIST
YESE: HLRZ C,(A) ;AGAIN
BRACKN C ;A BRACKETED TRIPLE?
JRST Y1 ;NO
MOVE FP,OLDITM(TABL) ;PREPARE TO LINK ON LIST.
MOVE D,(C) ;THE ONE-WORD CELL
HRL FP,D ;ITEM NUMBER
MOVEM FP,(C) ;THIS IS THE THE OLD ITEM LIST.
HRRZM C,OLDITM(TABL)
AOS FREITM(TABL) ;COUNT THE NUMBER FREE
MOVEI C,(D) ;ITEM NUMBER
HLLZS @INFOTAB(TABL) ;ZERO INFOTAB ENTRY (WONDERS OF INDIRECT ADDR)
CAME A,@DATAB(TABL) ;SAME ASSOC. POINTER TO BRACKET INFO.
ERR <DRYROT -BRACKET CONFUSION>
SKIPA
Y1: HLLZ D,(A) ;OLD POINTER ELSEWISE
Y2: HLLM D,(B) ;CHAIN NEW VALUE LINK.
LDB C,[POINT ITLEN,1(A),ITLEN-1];ATTRIBUTE
LDB D,[POINT ITLEN,1(A),2*ITLEN-1];OBJECT
HASH (B,C,D)
MOVE C,1(A) ;PICK UP THE WORD WE SEARCH FOR
TRZ C,7777 ;AND TURN OFF VALUE.
MOVE PNT,(B) ;FIRST IN CONFLICT LIST
LOOK: CAIN PNT,(A) ;DO WE POINT THERE?
JRST THISIT ;YES
MOVE D,1(PNT) ;GET A-O-V
CAMN D,C
JRST MULVLL ;A-O MATCH AT LEAST
MOVE B,PNT ;REMEMBER WHO POINTED AT US
HRRZ PNT,(PNT) ;GO DOWN CONFLICT LIST.
JUMPN PNT,LOOK ;AND LOOP
ERR <DRYROT -- ERASE2> ;NOT ON CONFLICT LIST
THISIT: HRRZ PNT,(A) ;CONFLICT
HRRM PNT,(B) ;BYPASS AROUND US.
JRST LINK ;RECLAIM THE WORD OF CORE.
MULVLL:
HLRZ C,(PNT) ;POINTER TO MULTIPLE HITS.
CAIN C,(A) ;IS THIS IT?
JRST FIST ;-- YESS AND THEFIRST ONE.
M1: SKIPN B,C
ERR <DRYROT -- ERASE3>;RFS FORGOT THIS ERROR CHECK - KKP
HRRZ C,(C) ;GET NEXT MULTIPLE HIT.
CAIE C,(A)
JRST M1 ;LOOP UNTIL FOUND
JRST THISIT
FIST: HRRZ D,(A) ;NEXT IN LINE...
JUMPE D,MHDEL ;NONE LEFT WILL DELETE MH HDR
HRLM D,(PNT) ;MH LIST
JRST LINK ;RELEASE ASSOC TWO WORDS
MHDEL: MOVE FP,FP2(TABL)
HRRZM FP,(A)
HRRZM A,FP2(TABL)
SETZM 1(A)
MOVEI A,(PNT)
JRST THISIT ;DELETE MH HDR
LINK: HRRZ FP,FP2(TABL)
HRRZM FP,(A)
SETZM 1(A)
HRRZM A,FP2(TABL)
JRST TRY
; LEAP BREAKPOINTS EXIST.
; ENTRY IS WITH ROUTINE ADDRESS IN C.
LPBRK: PUSH P,A ;ENTRY FROM ERASE.
PUSH P,FPD ;A → ASSOCIATION TO BE ERASED.
LDB B,[POINT 12,1(A),11]
PUSH P,B
LDB B,[POINT 12,1(A),23];OBJECT
PUSH P,B
LDB B,[POINT 12,1(A),35];VALUE
PUSH P,B
PUSH P,B ;STACKS NEED TO BE EQUAL.
PUSHJ P,LPBRK1 ;GO DO IT.
SUB P,[XWD 4,4] ;ALL GONE.
POP P,FPD
POP P,A
POPJ P,
LPBRK1: ;ENTRY FROM MAKE.
HRL TEMP,LEABOT(USER)
ADD P,[XWD FRCHLEN,FRCHLEN]
SKIPL P ;SEE IF WE OVERFLEW THE STACK.
PDLOF ;YES, SIGH.
HRRI TEMP,1-FRCHLEN(P)
BLT TEMP,(P) ;SAVE WORK AREA. SINCE BRK MAY CALL LEAP
PUSH P,FLAG
PUSH P,UUO1(USER)
GLOB <
NOSEC ;SO BREAKPOINT ROUTINE CAN CALL LEAP
PUSH P,TABL
PUSH P,-7-FRCHLEN(P) ;ATTRIBUTE
PUSH P,-7-FRCHLEN(P) ;OBJECT
PUSH P,-7-FRCHLEN(P) ;VALUE
>;GLOB
NOGLOB<
PUSH P,-6-FRCHLEN(P) ;ATTRIBUTE
PUSH P,-6-FRCHLEN(P) ;OBJECT
PUSH P,-6-FRCHLEN(P) ;VALUE
>;NOGLOB
PUSHJ P,(C) ;CALL ROUTINE
GLOB <
POP P,TABL
>;GLOB
MOVE USER,GOGTAB ;SET UP AGAIN.
POP P,UUO1(USER)
SUB P,[XWD FRCHLEN+1,FRCHLEN+1];REMOVE OLD FLAG AND OLD SCB
HRLI TEMP,1(P)
HRR TEMP,LEABOT(USER)
HRRI FLAG,FRCHLEN-1(TEMP)
BLT TEMP,(FLAG) ;RESTORE OLD SCB
MOVE FLAG,FRCHLEN+1(P) ;RETRIEVE FLAG
GLOB <
WRITSEC ;IN CASE GLOBAL
>;GLOB
POPJ P,
INTERNAL BRKERS,BRKMAK,BRKOFF ;BREAKPOINT FOR ERASE,BREAKPOINT FOR MAKE.
HERE (BRKERS)
SKIPA TEMP,[ERBP]
HERE (BRKMAK)
MOVEI TEMP,MKBP;THE POSITIONS.
ADD TEMP,GOGTAB;HO HO.
POP P,USER
POP P,(TEMP);SUBROUTINE NAME.
JRST (USER)
HERE (BRKOFF) ;TURN OFF BREAKPOINTS
MOVE USER,GOGTAB
SETZM ERBP(USER)
SETZM MKBP(USER)
POPJ P, ;RETURN
DSCR ISTRIPLE, SELECTOR
⊗;
; INITIALIZATION ROUTINE FOR THE ROUTINES THAT FOLLOW.
;ALL THESE ROUTINES ARE CALLED BY PUSHJ P,
INIT1:
; MOVE FRTAB,FRLOC(USER)
MOVE B,-2(P) ;ARGUMENT
; TLNE FLAG,BOUND⊗ATTPOS
; XCT MOVEB(FRTAB)
MOVE C,B ;COPY ITEM NUMBER
ADD C,INFOTAB(TABL) ;ADDRESS OF TYPE FLAGS
LDB C,[POINT 9,(C),35];GET TYPE FLAGS
ADD B,DATAB(TABL) ;ADDRESS TRIPLE POINTER
POPJ P,
; ISTRIPLE
ISTRIPLE:
PUSHJ P,INIT1
CAIE C,BRKITM
TDZA A,A
SETOM A
RET: SUB P,X22
JRST @2(P)
SELECTOR: ;FOR COMPUTING FIRST,SECOND,THIRD.
PUSHJ P,INIT1
CAIE C,BRKITM ;IS IT BRACKETED
JRST ERR1 ;NO, ERROR
HRRZ C,(B)
MOVE B,1(C) ;GET A-O-V GUY.
TRNN B,-1
ERR1: ERR <NOT A BRACKETED TRIPLE>,1
SUBI FLAG,SELET1-ROUTABLE-2
TRNE FLAG,1
LSH B,ITLEN
TRNE FLAG,2
LSH B,-(2*ITLEN)
ANDI B,7777 ;A FULL-FLEDGED ITEM
MOVEM B,-1(P) ;STORE IT AS A RETURNED VALUE
POPJ P,
DSCR DELETE, NEW (VARIOUS KINDS), AND ARRAY ITEM CODE.
DELETE -- ITEM PASSED IN STACK. IT IS DELETED. THIS INVOLVES
COPYING IT ONTO THE "RECENT FREE ITEM" LIST,
REMOVING ITS PRINTNAME IF ANY, RELEASING THE
ARRAY WHICH WAS ITS DATUM IF THAT WAS THE CASE,
AND PERHAPS DOING AN "ERASE" ON THE BRACKETED
TRIPLE THAT IT REPRESENTED.
NEW AND NEWX -- RETURN WITH THE STACK BUMPED BY ONE, AND
THE TOP OF STACK HAS A SHINY NEW ITEM. THE
DATUM ENTRY IS ZEROED. THE INFOTAB ENTRY IS NOT
ZEROED IN CASE THERE ARE ERRONEOUS ASSOCIATIONS
STILL USING THAT VALUE LIST.THE RIGHT HALF OF INFOTAB
WILL CONTAIN 0 PROPS FIELD AND TYPE OF NEW ITEM (FROM
LEFT HALF OF FLAG)
NEWART -- CALL IS WITH ARITHMETIC VALUE IN STACK.
RETURNS A NEW ITEM NUMBER, WITH ARITHMETIC VALUE
STUFFED IN DATUM ENTRY.
NEWARY -- CALL IS WITH ARRAY DESCRIPTOR IN STACK.
RETURNS A NEW ITEM NUMBER, WITH DESCRIPTOR OF
COPIED ARRAY STUFFED IN DATUM ENTRY.
⊗;
DELETE: ;JRST TO DELETE....
HRRZ A,HASHP(USER) ;IF THERE ARE PRINTNAMES.
JUMPE A,NOPRN ;NO
PUSH P,(P) ;ITEM NUMBER.
PUSHJ P,DEL.PNAME ;DELETE THE PNAMES.
NOPRN:
PUSH P,(P) ;COPY ITEM NUMBER
MOVE C,(P) ;GET ITEM NUMBER
GLOB <
TLNN FLAG,GLBSRC ;LOCAL DELETE?
CAIG C,GBRK ;HAD BETTER BE LOCAL ITEM.
SKIPA
ERR <LOCAL DELETE OF GLOBAL ITEM>,1
TLNE FLAG,GLBSRC ;GLOBAL DELETE?
CAIL C,GBRK ;HAD BETTER BE GLOBAL ITEM.
SKIPA
ERR <GLOBAL DELETE OF LOCAL ITEM>,1
>;GLOB
PUSHJ P,TYPEX ;GET TYPE
HLRZ B,A ;ADDRESS OF DATUM
HRRZS A ;TYPE
CAIE A,PRCTYP ;PROCESS TYPE?
JRST NTPRCT
PUSH P,UUO1(USER) ;SINCE TERMIN WILL DESTROY
PUSH P,A
PUSH P,B
PUSH P,C
PUSH P,C
PUSHJ P,TERMIN
POP P,C
POP P,B
POP P,A
MOVE USER,GOGTAB
POP P,UUO1(USER)
GLOB <
MOVEI TABL,(USER)
>;GLOB
JRST CLRDAT
NTPRCT:
JUMPN A,.+2 ;ALREADY DELETED?
ERR <DELETE - DELETED NON-EXISTANT ITEM>
GLOB<
WRITSEC ;CRITICAL SECTION
>;GLOB
ADD C,INFOTAB(TABL) ;
HLLZS (C) ;MARK AS DELETED
CAIE A,BRKITM ;BRACKETED TRIPLE?
JRST NOBRACK ;NO
;BRACKETED TRIPLE
MOVE C,(B) ;ADDR ASSOC.
HLRZ PNT,(C) ;A-O-V OF BRACKET
BRACKN (PNT) ;REALLY A BTRIP?
ERR <DRYROT-BRACKETED TRIPLE DELETE>,1 ; NO
HLRZ D,(PNT) ;NEXT IN VALUE LIST
HRLM D,(C) ;ASSOC NO LONGER BTRIP
JRST LINKOLD ;LINK BTRIP ITEM INTO FREELIST
NOBRACK:
CAIG A,ARRTYP ;SEE IF ARRAY
JRST CLRDAT ;NO CLEAR DATUM
CAIN A,INVTYP ;INVALID TYPE?
ERR <DRYROT - ITEM TYPE CONFUSION>
CAIE A,LSTYPE+ARRTYP
CAIN A,SETYPE+ARRTYP
JRST [ PUSH P,A ;CALL WILL DESTROY
MOVE A,(B) ;ARRAY DESCRIPTOR
PUSHJ P,ARRRCL
POP P,A
JRST .+1]
PUSH P,B ;SAVE AC B
SKIPN B,(B) ;DATUM
ERR <DRYROT - DELETE MISSING ARRAY ITEM>,1
CAIE A,STTYPE+ARRTYP ;STRING ARRAY
JRST RELGO ;NO.
MOVEI LPSA,ARYLS(USER) ;LINKED LIST OF STRING ARRAYS
MOVE C,ARYLS(USER) ;
HLRZ D,(C) ;ARRAY POINTER
CAIE D,(B) ;RIGHT ONE?
JRST [MOVEI LPSA,(C)
HRRZ C,(C)
JUMPN C,.-2
ERR <STRING ARRAY ITEM CONFUSION>]
HRR D,(C) ;REMOVE FROM ARYL LIST
HRRM D,(LPSA)
HRR D,FP1(USER) ;LINK ONTO FREE LIST
HRRM D,(C)
HRRM C,FP1(USER) ;
SUBI B,1 ;ADDR STRING ARRAY ITEM
RELGO: HLRE C,-1(B) ;NUMBER OF DIMENSIONS
MOVMS A,C ;WILL DO 2 ADDS TO SIMUL. MULT BY 3
ADDI C,(C)
ADDI C,(A)
SUBI B,2(C) ;NOW A CORGET POINTER
PUSHJ P,CORREL ;RELEASE ARRAY SPACE
POP P,B ;DATUM ADDRESS
JRST ARRCLR
CLRDAT: CAIE A,LSTYPE ;A SIMPLE LIST?
CAIN A,SETYPE ;A SIMPLE SET
JRST [SKIPN A,(B) ;SEE IF NULL LIST OR SET
JRST .+1 ;NULL SO IGNORE
SKIPG A ;TEMP?
ERR <DRYROT-TEMP. CONTAINED IN ITEM LIST OR SET >
PUSH P,B ;SAVE DATUM ADDRESS
PUSHJ P,RECQQ ;RECLAIM LIST SPACE
POP P,B
JRST ARRCLR]
CAIN A,CTXTYP ;A CONTEXT ITEM?
JRST [PUSH P,UUO1(USER) ;ALLFOR DESTROYS
PUSH P,B ;THE ADDRESS OF CONTEXT
PUSHJ P,ALLFOR
MOVE USER,GOGTAB
POP P,UUO1(USER)
JRST ARRCLR]
CAIE A,STTYPE ;A STRING ITEM
JRST ARRCLR ;NO.
MOVE A,(B) ;ADDRESS STRING DESCRITOR
SETZM -1(A) ;NULL STRING
HLRZ C,HASHP(USER) ;OLD STRING LIST
HRRM C,(A) ;LINK DELETED DESCRIPTOR ONTO IT
HRLM A,HASHP(USER) ;SAVE NEW LIST
↑ARRCLR:
GLOB<
SKIPN FP,FP1(TABL) ;ANY FREES YET?
PUSHJ P,FP1DON ;NONE YET. GET SOME.
>;GLOB
NOGLOB <
MOVE FP,FP1(TABL) ;NEED TO MAKE FREE ITEM CELL
>;NOGLOB
MOVEI PNT,(FP) ;ADDRESS NEW CELL
SKIPN FP,(FP) ;FOR NEXT TIME
PUSHJ P,FP1DON ;GET SOME MORE IF NECESSARY
HRRM FP,FP1(TABL) ;UPDATE FREE STORAGE LIST HEAD
LINKOLD:SETZM (B)
MOVS B,(P) ;ITEM NUMBER
HRR B,OLDITM(TABL)
MOVEM B,(PNT)
MOVEM PNT,OLDITM(TABL) ;UPDATE LIST OF DELETED ITEMS
AOS FREITM(TABL) ;INCREASE COUNT OF FREE
ALDDD: POP P,A ;REMOVE ITEM
JRST LEAV ;EXIT
NEW: ;GET A NEW ITEM NUMBER.
NEWX:
GLOB <
WRITSEC ;ENTER CRITICAL SECTION.
>;GLOB
SKIPN C,OLDITM(TABL) ;SEE IF ANY DUSTY OLD ITEMS.
JRST [
GLOB <
TLNE FLAG,GLBSRC;IF GLOBAL THEN
SOSA C,MAXITM(TABL);USE GLOBAL COUNT.
>;GLOB
AOS C,MAXITM(USER);USE LOCAL ITEM NUMBER.
GLOB <
CAIGE C,GBRK ;ABOVE THE BREAK?
JRST [ TLNE FLAG,GLBSRC; WAS IT A GLOBAL SEARCH
ERR <GLOBALS OVERFLOWED INTO LOCALS>,1
JRST REITM] ;NO --PROCEED.
TLNN FLAG,GLBSRC ;IF GLOBAL REQUEST, OK.
ERR <LOCALS OVERFLOWED INTO GLOBALS>,1
CAIGE C,TOPITM ;IF GONE TOO HIGH.
>;GLOB
NOGLOB <
CAMGE C,ITMTOP(USER);IF GONE TOO HIGH. THEN
>;NOGLOB
JRST REITM
ERR <ITEM SPACE EXHAUSTED>]
MOVEI B,(C) ;PREPARE TO FREE THE ONE WORD
MOVS C,(C)
HLRZM C,OLDITM(TABL) ;UPDATED POINTER.
HRR FP,FP1(TABL) ;WILL ADD WORD FROM OLDITM LIST
HRRM FP,(B) ;LINK ON
HRR B,FP1(TABL) ;NEW HEAD OF ONE-WORD FREES
ANDI C,TOPITM ;ITEM NUMBER.
REITM:
SOS FREITM(TABL) ;ONE LESS FREE
GLOB <
TLNN FLAG,GLBSRC
>;GLOB
SETZM @DATM ;ZERO THE DATUM.
GLOB <
TLNE FLAG,GLBSRC ;IF GLOBAL THEN
SETZM @GDATM ;ALSO ZERO THE GLOBAL DATUM.
>;GLOB
MOVE A,INFOTAB(TABL) ;ADDRESS INFOTAB
ADDI A,(C) ;ADDRESS THIS ITEM ENTRY
HLLZ B,FLAG ;GET TYPE CODE
GLOB< TLZ B,GLBSRC ;TURN OFF GLBSRC BIT
>;GLOB
HLRM B,(A) ;STORE TYPE CODE
EXCH C,(P) ;RECORD NEW ITEM NUMBER
;IN STACK.
JRST (C) ;EXIT.
NEWART: ;PUSHJ HERE FOR NEW WITH ARITHMETIC TYPE
POP P,FRTAB ;RETURN ADDRESS.
HLRZ B,FLAG
CAIE B,STTYPE ;IF STRING THEN VALUE IS NOT ON PSTACK
POP P,FPD ;VALUE
PUSHJ P,NEWX ;GET NEW ITEM
MOVE PNT,(P)
ADD PNT,DATAB(TABL)
MOVEM FPD,(PNT) ;DATUM...
HLRZ B,FLAG
GLOB<
TRZ B,GLBSRC ;TURN IF OFF IF ON
>;GLOB
CAIE B,LSTYPE ;LIST?
CAIN B,SETYPE ;SET
JRST [PUSH P,FPD
PUSH P,FRTAB ;RETURN ADDRESS
MOVEI TAC1,(PNT)
JRST DUPSET] ;MUST COPY
CAIE B,STTYPE ;STRING?
JRST (FRTAB) ;NO,RETURN.
PUSH P,FRTAB ;RETURN ADDRESS
PUSHJ P,SDESCR ;GET AN NIL STRING DESCRIPTOR
POP P,A ;ADDRESS DESCRIPTOR
MOVEM A,(PNT) ;ADDRESS INTO DATAB
POP SP,(A)
POP SP,-1(A) ;STORE INITIAL STRING
POPJ P, ;RETURN
NEWARY: ;JRST HERE
GLOB <
TLNE FLAG,GLBSRC
SETOM USCOR2(USER)
>;GLOB
PUSHJ P,ARCOP ;COPIES THE ARRAY IN -1(P)
PUSH P,A ;SAVE POINTER
;RETURNS POINTER IN A
PUSHJ P,NEW ;GET A NEW ITEM.
;ITEM IS ON TOP OF STACK.
MOVE A,-1(P) ;POINTER
MOVE PNT,(P) ;ITEM NUMBER
JSP FPD,ARYL ;MARK AN ARRAY; LINK INTO ARYLS.
POP P,A ;ITEM NUMBER
EXCH A,(P) ;EXCHANGE WITH ARRAY POINTER
HLRZ B,FLAG ;GET TYPE CODE OF NEW ARRAY
GLOB <
TRZ B,GLBSRC ;TURN OFF GLBSRC
>;GLOB
CAIE B,SETYPE+ARRTYP ;A SET ARRAY?
CAIN B,LSTYPE+ARRTYP ;A LIST ARRAY?
PUSHJ P,COPARR ;YES
GLOB <
SETZM USCOR2(USER)
>;GLOB
JRST LEAV
↑COPARR:PUSH P,A ;ADDRESS BASE OF ARRAY
SOS (P) ;SO AOS WILL WORK BELOW
PUSH P,-1(A) ;SIZE OF ARRAY
HRRZS (P) ;REMOVE DIMENSION INFO.
LPCOPA: SOSGE (P) ;THROUGH COPYING?
JRST [ SUB P,X22
POPJ P,]
AOS TAC1,-1(P) ;ADDRESS THIS SET
PUSH P,(TAC1) ;SET TO BE COPIED
PUSHJ P,DUPSET ;COPY SET
JRST LPCOPA ;LOOP
;THIS IS THE "NEW ARRAY" CODE.
;THIS MAKES ARRAYS FOR ITEMS AND PUTS THE DESCRIPTOR IN THE
;DATUM TABLE
GLOB <
;IF FLAG HAS GLBSRC ON, THIS IS GOING TO BE A GLOBAL ARRAY.
;IF FLAG HAS THE ARRTYP BIT IN THE LEFT HALF, THIS IS A REAL LEAP
;ARRAY (MEANING IT IS THE DATUM OF SOME ITEM)
;IF FLAG DOES NOT HAVE THE ARRTYP BIT SET IN THE LEFT HALF,
;IT IS PRESUMABLY A GLOBAL ARRAY OF SOME SORT.
>;GLOB
ITMYR: ;COMPILED IN LOCAL ARRAY ITEM
HLRZ A,TEMP ;LEFT OVER FROM HRLI FOR
POP P,PNT ;ITEM NUMBER.
MOVEI FPD,LEAV ;IN LINE CALL.
JRST ARYPUT ;COMPILED IN ARRAY.
ITMRY: ;COMPILED IN GLOBAL ARRAY OR ARRAY ITEM
MOVE C,UUO1(USER) ;RETURN ADDRESS SINCE ARMAK WILL DESTROY.
GLOB <
HRRZ B,@UUO1(USER) ;THIS IS ADDRESS OF THE MOVEM ....
TLNE FLAG,ARRTYP ;THIS IS THE LPARRAY BIT
JRST [
>;GLOB
POP P,B ;ITEM NUMBER.....
MOVE D,B ;ITEM NUMBER
ADD B,DATAB(TABL) ;NOW INDEX TO DATUM.
GLOB <
JRST .+1]
TLNE FLAG,GLBSRC ;SEE IF GLBMODEL
JRST [SKIPE (B) ;IS IT THERE ALREADY?
JRST FIXUP ;YES -- FIXUP STACK FOR EXIT.
SETOM USCOR2(USER);GET IT NOW
JRST .+1]
>;GLOB
PUSHJ P,ARMAK ;MAKE AN ARRAY
;RETURNS DESCRIPTOR IN A.
MOVEM A,(B) ;AND RECORD ANSWER SINCE AC B WAS SAVED.
MOVEM C,UUO1(USER) ;AND PUT THIS BACK.
GLOB <
SETZM USCOR2(USER) ;PUT IT BACK.
TLNN FLAG,ARRTYP ;THIS IS ON IF A LEAP ARRAY.
JRST LEAV ;GO AWAY -- IT WAS A SIMPLE GLOBAL ARRAY.
>;GLOB
MOVE PNT,D ;IT WAS AN ARRAY ITEM -- THIS IS THE ITEM
MOVEI FPD,LEAV ;IN LINE CALL.
;STUFF BELOW IS CALLED AS SUBROUTINE.
; ARYL RECORDS THE ARRAY IN A IN LIST OF STRING ARRAY ITEMS ARYLS
; IT ALSO SETS UP THE DATUM AND INFOTAB ENTRIES CORRECTLY.
;INPUT --- A HAS THE ARRAY DESCRIPTOR
; PNT HAS THE ITEM NUMBER (PASSED AS PARAM).
GLOB <
; FLAG HAS THE GLBSRC BIT ON IF THIS IS A GLOBAL ARRAY.
>;GLOB
ARYL:
GLOB <
TLNE FLAG,GLBSRC
JRST NOGLH ;DO NOT PUT ON LISTS.
>;GLOB
HLRZ C,FLAG ;GET TYPE OF ARRAY
CAIE C,STTYPE+ARRTYP ;STRING ARRAY?
JRST NOGLH ;NO.
GLOB <
SKIPN FP,FP1(TABL) ;FOR ARRAY LISTS
PUSHJ P,FP1DON ;NONE YET, GET SOME.
HRRZ C,FP
SKIPN FP,(FP)
>;GLOB
NOGLOB <
HRRZ C,FP1(TABL) ;FOR ARRAY LISTS
SKIPN FP,(C)
>;NOGLOB
PUSHJ P,FP1DON
MOVEM FP,FP1(TABL)
HRRZ D,A ;STRING ARRAY POINTER
HRL D,ARYLS(USER) ;CURRENT LINKED LIST OF ARRAYS.
MOVSM D,(C) ;IN NEW BLOCK.
HRRZM C,ARYLS(USER) ;AND UPDATE LIST
NOGLH:
ARYPUT: HRRZ B,PNT ;ITEMNUMBER
ADD B,DATAB(TABL) ;POINTER TO DATUM
MOVEM A,(B) ;PUT DOWN DESCRIPTOR.
JRST (FPD) ;RETURN.
GLOB <
FIXUP: ;FIXUP THE ARMAK CALL....
MOVM B,(P) ;NUMBER OF PARAMS.
LSH B,1 ;MULT. BY TWO.
ADDI B,1
HRLI B,(B) ;XWD PARAM+1,PARAM+1
SUB P,B ;O GOD.
TLNN FLAG,ARRTYP
AOS UUO1(USER) ;PAST THE MOVEM......
JRST LEAV
>;GLOB
NOEXPO <
INTERNAL IFGLOBAL
HERE (IFGLOBAL)
GLOB <
PUSH P,C ;SAVE B
MOVE C,-2(P) ;ITEM TO BE TESTED
CAIL C,TOPITM ;TOO HIGH?
JRST NTGLB
CAMGE C,MAXITM+GLUSER ;TOO LOW?
JRST NTGLB
LDB C,GINFTB ;ALLOC?
SKIPN C
;; #JI# BY JRL 10-2-72
NTGLB: TDZA A,A
;; #JI#
MOVNI A,1
POP P,C
>;GLOB
NOGLOB <
MOVEI A,0 ;NO GLOBAL ITEMS
>;NOGLOB
SUB P,X22
JRST @2(P)
>;NOEXPO
DSCR SET AND ITEM STORING OPERATIONS.
IF THE TOP OF THE STACK IS AN ITEM, WE OCCASIONALLY CALL
"STORE" TO STORE IT INTO SOME CORE LOCATION. THE COMPILER
SHOULD BE FIXED TO SIMPLY "POP" THE THING OFF INTO THE RIGHT
SPOT.
HOWEVER, IF THE TOP OF THE STACK IS A SET, WE REALLY DO NEED
TO DO SOME SCREWING AROUND. HENCE, CALLING "STORE" IS MORE
OR LESS NEEDED.
ALL ENTRIES NEED: TAC1 HAS ADDRESS OF TARGET LOCATION.
IF LH (TAC1) = -1, THEN THE TARGET IS A SET DESCRIPTOR.
THE VARIOUS ENTRIES ARE:
STORITM -- MAIN STORE ROUTINE. STORE ITEM OR SET ON TOP OF
STACK. SUBTRACT STACK WHEN DONE.
POPSET -- STORE TOP OF STACK (MUST BE SET) INTO AC 1.
(NO LONGER COMPILED), MAY BE DELETED WHEN SAISG5 IS
STORBUTDONTREMOVE -- SAME AS STORITM, BUT STACK IS NOT
SUBTRACTED.
SETCOP -- THE SET AT THE ADDRESS SPECIFIED BY TAC1 IS
COPIED OVER INTO ITSELF. THIS IS FOR SETS
PASSED AS VALUE PARAMETERS TO PROCEDURES. IF
THE ACTUAL IS A "TEMP SET", THEN NO ACTUAL
COPY IS MADE. THE INVERSE OF SETCOP IS:
SETRCL -- RECLAIM THE SET POINTED TO BY TAC1. THE STORAGE
IS LINKED BACK ON THE FREE STORAGE LIST.
⊗;
SETCOP: PUSH P,(TAC1) ;THE SET TO BE COPIED.
TLZ TAC1,777
JRST SETGO ;ALWAYS RECOPY.
POPSET: SETZM RACS+1(USER) ;TO MAKE TARGET SET LOOK NULL.
HRROI TAC1,RACS+1(USER)
JRST STORITM
STORBUTDONTREMOVE:
TLOA TAC1,777 ;THESE BITS WILL TELL US WHETHER
STORITM: ;TO ADJUST THE STACK ON EXIT.
TLZ TAC1,777
JUMPL TAC1,SETSTOR
MOVE B,(P) ;ITEM ARGUMENT.
TLNE FLAG,BOUND⊗ATTPOS
PUSHJ P,BSATIS ;FOR IMBEDDED STORES IN FOREACHES
MOVEM B,(TAC1) ;STORE IT.
JRST DECIDE ;ARRANGE STACK ACCORDINGLY.
BSATIS: PUSH P,FRTAB ;SAVE AC
PUSH P,C
MOVE FRTAB,FRLOC(USER) ;CURRENT FOR EACH TABLE
SKIPE C,RUNNER
MOVE FRTAB,CURSCB(C)
POP P,C
XCT MOVEB(FRTAB) ;GET SATISFIER
TRZ B,BNDFOR
POP P,FRTAB ;RESTORE AC
POPJ P, ;RETURN
SETSTOR: ;SET IS TO BE STORED.
GLOB <
TRNE TAC1,400000 ;A SECOND SEGMENT SET??
JRST [MOVSI FLAG,GLBSRC
MOVEI TABL,GLUSER;FIX IT UP
JRST .+3]
TLNE FLAG,GLBSRC
WRITSEC ;ENTER CRITICAL SECTION.
>;GLOB
SKIPE A,(TAC1) ;IS OLD SET THERE?
CAMN A,(P) ;IF NULL SET, OR SAME AS ON STACK.
JRST SETGO ;DO NOT RECLAIM OLD ONE.
MOVE FP,FP1(TABL)
HLRZ B,(A) ;RECLAIM STORAGE
HRRM FP,(B)
HRRM A,FP1(TABL) ;VERY FAST !
SETGO:
GLOB <
TLNE FLAG,GLBSRC ;IF GLOBAL SEARCH, THEN
JRST [MOVE A,(P) ;GET SET....
JRST COPYQ] ;AND COPY IT.
>;GLOB
SKIPGE A,(P) ;GET ARGUMENT.
JRST TEMPSET ;A TEMPORARY -- NO NEED TO COPY.
COPYQ: JUMPE A,NULLSET
PUSH P,[0] ;LET UNION DO THE WORK.
PUSHJ P,UNION ;MAGIC.
MOVE A,(P) ;RESULTS.
TEMPSET:
HLRE B,A ;GET COUNT FROM TEMP SET.
MOVMS B ;MAKE IT POSITIVE (I.E. PERMANENT SET)
HRL A,B ;ABSOLUTE COUNT.
MOVEM A,(TAC1) ;STORE IN DESCRIPTOR.
MOVEM A,(P) ;IN CASE OF STORBUTDONTREMOVE.
SKIPA
NULLSET:
SETZM (TAC1) ;TARGET SET IS EASY !
DECIDE: MOVE A,RACS+1(USER) ;IN CASE OF POPTOP'S
TLNN TAC1,777 ;LEAVE TOP OF STACK ON?
POP P,B ;NO --THROW OUT.
JRST LEAV ;YES
SETRCL: SKIPGE A,(TAC1) ;IF TEMP SET, CRASH
ERR <PROC EXIT WITH TEMP SET>,1
JUMPE A,LEAV ;NOT IF NULL SET.
PUSHJ P,RECQQ ;RECLAIM A SET IN A.
JRST LEAV ;AND RETURN.
DSCR DUPSET - COPY A SET OR LIST
-1(P) CONTAINS A SET DESCRIPTOR OF A SET TO BE COPIED
TAC1 CONTAINS THE ADDRESS OF THE DESTINATION OF THE COPIED SET.
IF THE SET IS NULL WE SIMPLY ZERO THE DESTINATION. IF THE
SET IS PERMANENT WE COPY IT INTO THE APPROPRIATE SEGMENT.
IF TEMP SET (NEG. LENGTH) AND LOCAL DESTINATION WE CHANGE
THE TEMP TO A PERM. SET. IF GLOBAL DEST. WE MUST COPY
THE TEMP INTO THE UPPER SEGMENT, SINCE ALL TEMPS ARE IN TH
LOWER SEGMENT. ALL AC'S EXCEPT USER MAY BE CHANGED. ⊗
DUPSET: SKIPN A,-1(P) ;NULL SET?
JRST [SETZM (TAC1) ;YES
SUB P,X22
JRST @2(P)]
JUMPL A,TMPSTC ;TEMP SET?
MSTCOP: ;HAVE TO COPY SET
GLOB <
JSP B,GQSET ;GLOBAL SET?
>;GLOB
PUSH P,A ;SET TO BE COPIED
PUSH P,[0] ;NULL SET
PUSHJ P,CATLST
EXTCOP: HLRE A,(P) ;MAKE INTO PERM. SET
MOVMS A
HRLM A,(P)
POP P,(TAC1)
SUB P,X22
JRST @2(P)
TMPSTC: ;TEMP SET TO BE COPIED
GLOB <
TRNE TAC1,400000 ;GLOBAL DESTINATION?
JRST MSTCOP ;THEN MUST COPY.
>;GLOB
PUSH P,-1(P)
JRST EXTCOP
DSCR SET OPERATIONS
PUTIN -- PUT TOP OF STACK IN SET POINTED TO BY TAC1.
THIS MAKES A PERMANENT SET (I.E. COUNT IN SET
DESCRIPTOR IS KEPT POSITIVE).
REMOV -- REMOVE THE ITEM MENTIONED IN TOP OF STACK FROM
THE SET POINTED TO BY TAC1. AN ERROR IS GIVEN IF THE
ITEM IS NOT A MEMEBER OF THE SET.
STLOP -- LOP OFF AN ELEMENT OF THE SET POINTED TO BY
TAC1, RETURN RESULTANT ITEM IN TOP OF STACK.
⊗;
;SET OPERATIONS.
;INITIALIZER FOR ALL SETS.
INSET:
SETZB LPSA ;FOR COUNTING PURPOSES.
;ALSO RIGHT HALF OF REGISTER
;0 MUST BE 0.
GLOB <
SKIPN FP,FP1(TABL) ;ONE-WORD FREES IF ANY
PUSHJ P,FP1DON ;NONE YET, GET SOME.
HRRZS FP
>;GLOB
NOGLOB <
HRRZ FP,FP1(TABL) ;ONE-WORD FREES IF ANY
>;NOGLOB
MOVEI FPD,(FP) ;ANOTHER COPY
HRROI PNT,(FP) ;AND ANOTHER COPY.
JRST (B) ;RETURN
GLOB <
GQSET: TRNE TAC1,400000 ;SECOND SEGMENT??
JRST [TLO FLAG,GLBSRC
MOVEI TABL,GLUSER
WRITSEC
JRST (B)]
MOVEI TABL,(USER)
NOSEC ;IN CASE IT WAS ON
TLZ FLAG,GLBSRC
JRST (B)
>;GLOB
;PUT AND REMOVE ----
; ITEM IS IN -1(P)
; => SET IN TAC1
PUTIN:
MOVE A,-1(P) ;ITEM. ;REPLACES BELOW
; SKIPN A,-1(P) ;ITEM. ;WAFFLE WAFFLE DCS 12-12-72
; ERR <PUT WITH UNBOUND ITEM>,1
ENTY:
GLOB <
JSP B,GQSET ;GET SET FOR GLOBAL MODEL.
>;GLOB
GLOB <
SKIPN FP,FP1(TABL)
PUSHJ P,FP1DON ;NONE YET, GET SOME.
HRRZS FP
>;GLOB
NOGLOB <
HRRZ FP,FP1(TABL)
>;NOGLOB
MOVEI PNT,(FP)
SKIPN B,(TAC1) ;HEADER FOR SET.
JRST INS1 ;BRAND NEW
LOPSET: MOVE C,B ;REMEMBER WHO POINTED AT US.
HRRZ B,(B) ;GO DOWN SET.
JUMPE B,INSRT ;GOT TO END AND NOT FOUND.
HLRZ D,(B) ;GET ITEM NUMBER
CAIGE D,(A) ;COMPARE TO ONE BEING INSERTED
JRST LOPSET ;NOT FAR ENOUGH
CAIN D,(A)
JRST RETQ ;ALREADY THERE.
INSRT: SKIPN FP,(FP) ;GET FREE STORAGE.
PUSHJ P,FP1DON ;NONE LEFT.
HRLM A,(PNT) ;STORE THE NEW ITEM
HRRM PNT,(C) ;PUT IN POINTER.
HRRM B,(PNT) ;DOWN POINTER
TRNE B,-1 ;WAS THIS THE LAST?
JRST COUTUP ;NO
MOVE B,(TAC1) ;GET SET AGAIN.
HRLM PNT,(B) ;PUT IN "LAST" POINTER.
COUTUP: MOVSI B,1
ADDM B,(TAC1) ;BUMP COUNTER
JRST RETQ
INS1: MOVEI PNT,(FP) ;POINTER TO FIRST FREE.
SKIPN FP,(FP)
PUSHJ P,FP1DON
MOVEI B,(FP) ;POINTER TO SECOND FREE.
SKIPN FP,(FP)
PUSHJ P,FP1DON
HRLZM A,(B) ;ITEM INSERTED
HRLM B,(PNT)
MOVEM PNT,(TAC1)
JRST COUTUP
;REMOVE
;SAME CALLING SITUATION AS PUT.
REMOV:
GLOB <
JSP B,GQSET
>;GLOB
JSP B,INSET
SETZM .SKIP.
HRRZ A,-1(P) ;THE ITEM
MOVE B,(TAC1) ;SET HEADER
LOPSS1: MOVE C,B
HRRZ B,(B)
JUMPE B,ERRS1 ;IT WAS NOT THERE
HLRZ D,(B) ;ITEM NUMBER
CAIE D,(A) ;COMPARE
JRST LOPSS1 ;GO FARTHER
ENREMX: CAMN C,(TAC1) ;THE FIRST ELEMENT?
JRST ZEROS ;YES
REG: HRRZ D,(B) ;DOWN POINTER.
HRRM D,(C) ;BYPASS THE CELL BEING DELETED.
HRRZ LPSA,(TAC1) ;POINTER TO SET HEADER.
HLRZ D,(LPSA) ;NOW THE POINTER TO LAST OF LIST.
CAIN D,(B) ;SAME AS ONE WE FOUND?
HRLM C,(LPSA) ;YES -- INSTALL NEW "LAST" ELEMENT.
HRRM FP,(B) ;LINK ON FREE STORAGE LIST
HRLZI C,-1
ADDM C,(TAC1) ;DECREMENT COUNTER.
GOREM: MOVE FP,B
RETQ: HRRM FP,FP1(TABL) ;
JRST RET0 ;ALL DONE.
ZEROS: TLNE C,-2 ;THE VERY LASTELEMENT OF LIST.
JRST REG ;NO -- DO A REGULAR REMOVE.
HRRM FP,(B) ;LINK WHOLE THING ON FS LIST.
ENZERO: HRRZ B,(TAC1) ;THIS IS NOW THE FS LIST.
SETZM (TAC1) ;AND ZERO THE DESCRIPTOR
JRST GOREM
ERRS1: SETOM .SKIP.
JRST RETQ
STLOP: PUSH P,(TAC1) ;THE SET.
PUSHJ P,UNIT ;GO GET THE FIRST ELEMENT IN (P)
PUSH P,[1] ;REMOVE FIRST
PUSHJ P,REMX ;REMOVE IT
JRST LEAV ;RETURN AND LEAVE ITEM ON TOP OF STACK.
DSCR MORE SET OPERATIONS
SIP -- FOR MAKING UP SETS FROM LISTS OF ITEMS { A,B,C }.
CALL IS WITH TOP OF STACK HAVING ITEM IN IT,
NEXT ELEMENT IN STACK IS THE SET WE ARE BUILDING.
STIN -- BOOLEAN TO SEE IF ITEM (SECOND ELEMENT DOWN IN
STACK) IS MEMBER OF SET (TOP OF STACK).
COUNT -- RETURNS IN AC1 THE LENGTH OF THE SET ON TOP
OF STACK.
UNIT -- RETURNS ON TOP OF STACK THE FIRST ELEMENT OF THE
SET WHICH IS ON THE TOP OF STACK.
SETEST -- CODE FOR TESTING SET BOOLEANS, I.E. SET CONTAINMENT,
EQUALITY, INEQUALITY, ETC.
⊗;
; SIP -- FOR MAKING UP SETS OF ITEMS.
;CALL IS WITH ITEM IN -1(P)
;SET STAYS IN -2(P) ..
SIP:
MOVE B,-1(P) ;ITEM
; SKIPN B,-1(P) ;ITEM ;CAUTION 12-12-72 DCS
; ERR <MAKING SET WITH UNBOUND ITEM>,1
TLNE FLAG,(BOUND!BINDING)⊗ATTPOS
PUSHJ P,BSATIS ;GET SATIS
MOVE A,B
MOVEI TAC1,-2(P) ;THE SET DESCRIPTOR.
HLRE B,(TAC1) ;COUNT
MOVMS B
HRLM B,(TAC1) ;MAKE POSITIVE.
PUSHJ P, ENTY ;SEE PUTIN AND FRIENDS.
HLRE A,(TAC1) ;COUNT OF SET.
MOVNS A
HRLM A,(TAC1) ;AND MAKE A TEMP.
SUB P,X11
JRST @2(P)
RET1: HRRM FP,FP1(TABL)
RET0: SUB P,X22
JRST @2(P)
; STIN -- A BOOLEAN OF THE FORM X ε SET
;CALL IS WITH X IN -2(P)
; SET IN -1(P)
STIN:
SETZM ;USES R0 FOR JUMPE...
MOVE B,-2(P) ;ITEM
TLNE FLAG,BOUND⊗ATTPOS
PUSHJ P,BSATIS ;GET SATIS
MOVE C,-1(P) ;THE SET
LOPT2: HRRZ C,(C) ;DOWN THE SET
JUMPE C,NOPE
HLRZ D,(C)
CAIE D,(B) ;THE ITEM?
JRST LOPT2
NOPE:
PUSHJ P,RECL1 ;RECLAIM IF NECESSARY.
RET3C: HRREM C,A ;SAVE IN REG 1 AS RESULT.
RET3: SUB P,X33
JRST @3(P)
; COUNT ....
; CALL IS WITH SET IN -1(P)
COUNT:
HLRE C,-1(P)
PUSHJ P,RECL1 ;RECLAIM -1(P) IF NECESSARY.
MOVMM C,A
JRST RET0 ;THAT'S ALL
; UNIT ...
; CALL IS WITH SET IN -1(P)
UNIT:
MOVE A,-1(P)
TLNN A,-1
ERR <LOP OR COP OF NULL SET OR LIST UNDEFINED>,1
HRRZ A,(A)
HLRZ PNT,(A) ;THING TO RETURN
PUSHJ P,RECL1 ;RECLAIM IF NECESSARY.
EXCH PNT,-1(P)
POPJ P,
;SET RELATIONS......
;VARIOUS LOCAL BITS.
TESNEQ←←40 ;TEST NOT EQUAL
TESEQL←←20 ;TEST EQUAL
TES12 ←←10 ;TEST 1⊂2
TES21 ←← 4 ;TEST 1⊃2
TESMAY←← 2 ;IMPROPER SUBSETS.
ANSWER←← 1 ;THE ANSWER 0 FOR FALSE, 1 FOR TRUE
;FALSE UNTIL PROVEN TRUE.
RELTAB:
TES12
TES21
TESEQL
TESNEQ
TES12!TESMAY
TES21!TESMAY
SETEST:
MOVE RELTAB-RELSTART+ROUTAB(FLAG) ;BITS!!!!
TRNN TES21
JRST .+4
MOVE B,-2(P) ;EXCHANGE THE OPERANDS.
EXCH B,-1(P)
MOVEM B,-2(P)
HLRE A,-2(P) ;EXAMINE COUNTS.
HLRE B,-1(P)
MOVMS A
MOVMS B
TRNN TESNEQ!TESEQL ;THESE GUYS WANT THE EQUAL TEST
JRST CONTES
CAIE A,(B)
JRST TESE
EQTST: JUMPE A,TESME ;IF NULL SETS, CLEARLY EQUAL
MOVE A,-2(P)
MOVE B,-1(P)
EQLOP: HRRZ A,(A) ;NEXT ELEMENT.
JUMPE A,TESME
HRRZ B,(B)
HLRZ D,(A)
HLRZ LPSA,(B) ;ITEMS
CAIN LPSA,(D) ;EQUAL?
JRST EQLOP
TESE: TRNE TESNEQ
SETYES: TRC ANSWER
SETNO:
SETANS: SETOM C
TRNN ANSWER
SETZM C
PUSHJ P,RECL2 ;RECLAIM....
JRST RET3C
TESME: TRNN TESNEQ
TRC ANSWER
JRST SETANS
CONTES: CAIE A,(B)
JRST TESREL ;NOT SAME LENGTH.
TRZN TESMAY
JRST SETNO ;NOT POSSIBLY CONTAINED.
JRST EQTST
TESREL: CAIL A,(B) ;POSSIBLY CONTAINED :: COUNT(1) < COUNT(2)?
JRST SETNO
JUMPE A,SETYES ;NULL SET CONTAINED IN ANY SET.
MOVE A,-2(P)
MOVE B,-1(P)
COMLP: HRRZ A,(A)
COMLP1: HRRZ B,(B)
JUMPE A,SETYES ;ALL DONE AND NOT KICKED OUT.
JUMPE B,SETNO ;TRY TO GO PAST END ? -- NOT FEASIBLE.
HLRZ D,(A)
HLRZ LPSA,(B)
CAIGE D,(LPSA) ;CONTAINED?
JRST SETANS ;NO -- RETURN NO.
CAIE D,(LPSA) ;THE VERY SAME?
JRST COMLP1
JRST COMLP
DSCR UNION, INTERSECTION, SUBTRACTION
IN EACH CASE, ARGUMENTS ARE PASSED IN TOP TWO STACK
POSITIONS. RESULT IS LEFT AS A TEMPORARY SET ON THE
TOP OF THE STACK.
⊗;
; UNION
; CALL IS WITH SETS IN -1 AND -2 (P)
UNION:
JSP B,INSET
MOVE A,-1(P)
MOVE B,-2(P) ;THE SETS
HRRZ A,(A)
HRRZ B,(B) ;AND PAST THE HEADERS.
LOPA1: JUMPE A,AEXH ;A IS EXHAUSTED
LOPA2: JUMPE B,BEXH
HLRZ C,(A) ;ITEM
HLRZ D,(B) ;THE OTHER ITEM
MOVEI PNT,(FP) ;THIS IS A FREE STOR. CELL.
SKIPN FP,(FP)
PUSHJ P,FP1DON
CAILE C,(D) ;WHICH ONE IS INSERTED?
SOJA LPSA,[HRLM D,(PNT) ;PUT IN ITEM
HRRZ B,(B)
JRST LOPA2]
HRLM C,(PNT)
CAIN C,(D) ;THE SAME ITEM?
HRRZ B,(B)
HRRZ A,(A)
SOJA LPSA,LOPA1 ;LOOP
AEXH: JUMPE B,DONN ;IF BOTH EXHAUSTED, DONE
HLRZ D,(B) ;NEXT ITEM
MOVEI PNT,(FP) ;FREE STORAGE CELL.
SKIPN FP,(FP)
PUSHJ P,FP1DON
HRLM D,(PNT)
HRRZ B,(B)
SOJA LPSA,AEXH
BEXH: JUMPE A,DONN
HLRZ D,(A)
MOVEI PNT,(FP)
SKIPN FP,(FP)
PUSHJ P,FP1DON
HRLM D,(PNT)
HRRZ A,(A)
SOJA LPSA,BEXH
;INTERSECTION.....
; CALL IS WITH SETS IN -1 AND -2 (P)
INTER:
JSP B,INSET
MOVE A,-1(P) ;FIRST SET
MOVE B,-2(P)
LOPS0: HRRZ A,(A)
LOPS1: HRRZ B,(B) ;GO ON DOWN....
LOPS2: JUMPE A,DONN ;IF EITHER A OR B DONE,
LOPS3: JUMPE B,DONN ;THEN WE ARE REALLY DONE.
HLRZ C,(A) ;ITEM
HLRZ D,(B) ;OTER ITEM
CAIN C,(D) ;THE SAME?
JRST YES4 ;YES
CAIL C,(D) ;IS THE A LIST LOWER?
JRST LOPS1 ;NO
HRRZ A,(A) ;YES
JRST LOPS2
YES4: MOVEI PNT,(FP)
SKIPN FP,(FP)
PUSHJ P,FP1DON
HRLM C,(PNT)
SOJA LPSA,LOPS0 ;GO PAST BOTH OF THEM.
; SUBRACTION .
; CALL IS WITH SUBTRAHEND IN -1(P), OTHER IN -2(P)
SUBTRA:
JSP B,INSET
MOVE A,-1(P)
MOVE B,-2(P) ;LARGER SET
LOPR1: HRRZ A,(A) ;PAST SET HEADER & DOWN THE LIST.
JUMPE A,[ADDI LPSA,1
JRST BCOP1] ;COPY THE REST OF B
HLRZ C,(A) ;THE ITEM
LOPR2: HRRZ B,(B)
JUMPE B,DONN
HLRZ D,(B) ;THE OTHER ITEM
LOPR3: CAIN C,(D) ;THE SAME?
JRST LOPR1 ;YES -- WALK ON BY.
CAIL D,(C) ;IS B LIST LOWER?
JRST [HRRZ A,(A)
JUMPE A,BCOP ;ALL DONE
HLRZ C,(A)
JRST LOPR3]
MOVEI PNT,(FP)
SKIPN FP,(FP)
PUSHJ P,FP1DON
HRLM D,(PNT)
SOJA LPSA,LOPR2
BCOP: JUMPE B,DONN
MOVEI PNT,(FP)
SKIPN FP,(FP)
PUSHJ P,FP1DON
HRLM D,(PNT) ;THERE WAS A THING IN D TO BE
;DISPOSED OF.
BCOP1: HRRZ B,(B) ;ON DOWN B.
HLR D,(B) ;ITEM NUMBER.
SOJA LPSA,BCOP
; LIST OR SET ELEMENT SELECTION. LIST OR SET
; DESCRIPTOR IN -1(P). SELECTOR INDEX ON TOP OF STACK
; ERROR DETECTED IF SELECTOR OUT OF RANGE
; ITEM RETURNED ON TOP OF STACK.
; ROUTINE IS JRST'ED TO.
SELFETCH: SKIPG A,(P) ;GET INDEX AMOUNT
JRST SELERR ;ERROR IF <=0
MOVE C,-1(P) ;SET ARGUMENT
HLRE B,C ;GET COUNT
MOVM B,B ;ABS. LENGTH OF SET
CAMG B,A ;TEST IF IN RANGE
JRST LSTELM ;LAST ELEM. OR ERROR
LPSEL: MOVE C,(C) ;NEXT NODE
SOJG A,LPSEL ;COUNT DOWN
COMSEL: HLRZ PNT,(C) ;ITEM TO BE RETURNED
PUSHJ P,RECL1 ;RECLAIM SET IF NECESSARY
MOVEM PNT,-1(P) ;VAL. TO BE RETURNED
POP P, ;POP OFF ARG.
JRST LEAV ;RETURN
LSTELM: CAME B,A ;SKIP IF LAST ELEMENT
JRST SELERR ;RANGE ERROR
HLRZ C,(C) ;ADDR LAST WORD IN LIST
JRST COMSEL ;NORMAL RETURN
SELERR: ERR <LIST SELECTOR OUT OF RANGE>
;CATLST CONCATENATES THE TWO LISTS ON THE TOP OF STACK
;FIRST LIST IS IN -2(P). SECOND LIST IS IN -1(P)
;RETURN ADDRESS IS IN (P).
↑CATLST: JSP B,INSET ;INITIALIZE
HLRE LPSA,-1(P) ;GET LENGTH FIRST LIST
MOVM LPSA,LPSA ;COUNT
HLRE A,-2(P) ;LENGTH OF SECOND LIST
MOVM A,A ;COUNT
ADD LPSA,A ;LENGTH OF NEW LIST
MOVN LPSA,LPSA ;NEGATIVE LENGTH OF NEW LIST
MOVEI B,2 ;CAT TWO LISTS
MOVE A,-2(P) ;FIRST LIST
PASTHD: HRRZ A,(A) ;BYPASS HEADER
JUMPE A,AEXCAT ;IF NULL LIST IGNORE
LPCAT: HLRZ C,(A) ;GET ITEM
MOVEI PNT,(FP) ;GET A FREE
SKIPN FP,(FP) ;FOR NEXT FREE
PUSHJ P,FP1DON ;GET NEW FREES
HRLM C,(PNT) ;COPY ITEM
HRRZ A,(A) ;CDR OF LIST
JUMPN A,LPCAT ;LOOP IF NOT THROUGH
AEXCAT: SOJE B,DONN ;IF SECOND SET, END
MOVE A,-1(P) ;SECOND SET
JRST PASTHD ;CAT IT
DSCR PUTAFTER,PUTBEFORE⊗
PUTAFTER: SKIPA LPSA,[0];LPSA=0 IF AFTER
PUTBEFOR: SETO LPSA, ;LPSA=-1 IF BEFORE
GLOB <
JSP B,GQSET ;GET LIST FOR GLOBAL MODEL
SKIPN FP,FP1(TABL) ;ANY FREES YET
PUSHJ P,FP1DON ; NO GET SOME
HRRZS FP ; A FREE
>;GLOB
NOGLOB <
HRRZ FP,FP1(TABL) ;A FREE NODE
>;NOGLOB
MOVE A,-1(P) ;SEARCH ITEM
POP P,-1(P) ;MAKE IT LOOK LIKE CALL TO PUTIN
MOVEI PNT,(FP) ;POINTER TO FIRST FREE
SKIPN B,(TAC1) ;NULL LIST?
JRST NEWLST ;YES.
LOPLST: MOVE C,B ;REMEMBER WHO POINTED TO US
HRRZ B,(B) ;CURRENT NODE
JUMPE B,LSTEXH ;LIST EXHAUSTED?
HLRZ D,(B) ;GET ITEM
CAIE D,(A) ;ONE WE'RE LOOKING FOR?
JRST LOPLST ;NO.
; AT THIS POINT NODE POINTED TO BY B CONTAINS THE ITEM WE
; WERE LOOKING FOR. C POINTS TO PREVIOUS NODE IN LIST.
MOVE A,-1(P)
; SKIPN A,-1(P) ;ITEM TO BE INSERTED ;DISCRETION IS ...
; ERR <PUT WITH UNBOUND ITEM>,1 ; 12-12-72 DCS
JUMPN LPSA,INSRT ;BEFORE THEN INSERT
MOVE C,B
HRRZ B,(B) ;FOR AFTER
JRST INSRT ;INSERT IT
NEWLST: MOVE A,-1(P) ;ITEM TO BE INSERTED
JRST INS1 ;INSERT IN NEW LIST
LSTEXH: MOVE A,-1(P) ;GET ITEM
JUMPE LPSA,INSRT ;AT END OF LIST
HRRZ C,(TAC1) ;GET LIST HEADER
HRRZ B,(C) ;INSERT AT HEAD OF LIST
JRST INSRT ;INSERT IT
; LIST [EXPR1 FOR EXPR2]
; LIST IN -3(P)
; expr1 IN -2(P)
; expr2 IN -1(P)
FSBLST:
SKIPGE A,-1(P) ;GET FOR EXPR
ERR <INVALID "FOR" INDEX IN SUBLIST>,1
ADD A,-2(P) ;CHANGE TO TO
SOJA A,TSBLST+1 ;NOW A TO EXPR.
; LIST [expr1 TO expr2]
; LIST IN -3(P)
; expr1 in -2(P)
; expr2 IN -1(P)
TSBLST: MOVE A,-1(P) ;GET TO EXPR VALUE
JSP B,INSET ;INITIALIZE NEW SET
SKIPG B,-2(P) ;EXPR1
ERR <INDEX FOR SUBLISTING ≤ 0>,1
LENLST: HLRE C,-3(P) ;GET LENGTH OF LIST
MOVM C,C ;ABS VAL. LENGTH
CAMLE A,C ;TO > LENGTH?
ERR <INVALID SUBLIST OPERATION,LIST NOT LONG ENOUGH>,1
STKMOD: POP P,-2(P) ;MODIFY STACK
SUB P,[XWD 1,1] ;MOD STACK
CAMLE B,A ;NULL SUBLIST?
JRST NULSUB ;YES.
;PREPARE TO BYPASS HEADER
SETZ C, ;COUNTER FOR LIST POSITION
MOVE D,-1(P) ;GET LIST HEADER
HDLST: HRRZ D,(D) ;NEXT
AOS C ;INC PLACE COUNTER
CAIGE C,(B) ;THROUGH?
JRST HDLST ; NO.
; (D) POINTS TO FIRST NODE TO BE COPIED
; CALCULATE NUMBER TO BE COPIED
SUB A,B
AOS A ;NUMBER OF NODES TO BE COPIED
MOVN LPSA,A ;NEGATIVE LENGTH FOR TEMP. SET
LPCPY: HLRZ B,(D) ;GET ITEM
MOVEI PNT,(FP) ;GET FREE
SKIPN FP,(FP) ;FOR NEXT TIME
PUSHJ P,FP1DON ;NEED SOME NEW FREES
HRLM B,(PNT) ;COPY ITEM
HRRZ D,(D) ;TO NEXT NODE
SOJG A,LPCPY ;IF NOT THROUGH LOOP
HLLZS (PNT) ;ZERO LAST PNTR.
MOVEI A,(PNT) ;ADDR LAST WORD IN LIST
MOVEI PNT,(FP) ;GET A FREE
SKIPN FP,(FP) ;FOR NEXT TIME
PUSHJ P,FP1DON ;IF OUT, GET SOME MORE
HRRM FPD,(PNT) ;ADDR. FIRST LIST NODE
HRLM A,(PNT) ;ADDR LAST LIST NODE
HRRM FP,FP1(TABL) ;FREE LIST UPDATE
HRLM LPSA,PNT ;STORE LIST LENGTH
RETLST: PUSHJ P,RECL1 ;RECLAIM SET IF NECESSARY
MOVEM PNT,-1(P) ;LIST TO BE RETURNED
POPJ P, ;RETURN
NULSUB: SETZ PNT, ;RETURN NULL LIST
JRST RETLST
; THE EXIT CODE
DONN:
JUMPL PNT,[SETZM PNT ;IF NOTHING DONE,
JRST RECLM2] ;RETURN NULL SET.
HLLZS (PNT) ;ZERO THE POINTER IN LAST CELL.
MOVEI A,(PNT) ;LAST WORD ALLOCATED.
MOVEI PNT,(FP) ;AND A NEW ONE -- FOR HEADER.
SKIPN FP,(FP)
PUSHJ P,FP1DON
HRRM FPD,(PNT) ; → FIRST OF SET LIST.
HRLM A,(PNT) ;PUT IN THE "LAST" LINK
HRLM LPSA,PNT ;LPSA IS NEGATIVE, TO INDICATE TEMP.
HRRM FP,FP1(TABL) ;....
; JRST RECLM2 ;NEXT PAGE.
DSCR SET RECLAMATION ROUTINES.
RECLM2 -- RECLAIMS TOP TWO STACK ELEMENTS, SUBTRACTS FROM
STACK, THEN PUSH'ES "PNT" (A RESULT) ONTO STACK.
RECL2 -- RECLAIMS SETS IN -1(P) AND -2(P) .. THOSE ARE
THE STACK POSITIONS BEFORE THE CALL TO RECL2.
RECQQ -- RECLAIMS SET MENTIONED IN REGISTER "A".
CLOBBERES ACS: FP AND B.
⊗;
RECLM2: PUSHJ P,RECL2
ALLD:
SUB P,X33
PUSH P,PNT
JRST @2(P) ;RETURN.
RECL2: SKIPGE A,-3(P) ;...
PUSHJ P,RECQQ
RECL1: SKIPL A,-2(P) ;RECLAIM IF NECESSARY.
POPJ P,
↑↑RECQQ:
GLOB <
TRNE A,400000 ;IF SECOND SEGMENT, THEN
JRST SECRCL ;DO SPECIALLY
>;GLOB
MOVE FP,FP1(USER)
HLRZ B,(A)
HRRM FP,(B) ;LINK AT THE END OF LIST.
HRRM A,FP1(USER)
POPJ P,
GLOB <
SECRCL: PUSH P,LKSTAT ;SAVE INTERLOCK STATUS
PUSH P,FLAG ;SAVE FLAG
TLO FLAG,GLBSRC
WRITSEC ;GAIN ACCESS TO POINTERS.
MOVE FP,FP1+GLUSER
HLRZ B,(A)
HRRM FP,(B)
HRRM A,FP1+GLUSER
POP P,FLAG ;RESTORE FLAG
POP P,A
CAMN A,LKSTAT ;SAME STATUS AS WHEN ENTERED
POPJ P, ;YES
JUMPN A,[RDSEC
POPJ P,]
NOSEC
POPJ P,
>;GLOB
; TRANSFER FUNCTION SET← LIST
; LIST IN (P) . RESULTANT SET WILL BE LEFT ON TOP OF STACK
; ROUTINE JRST`ED TO
SETLXT:
SKIPN A,(P) ;THE LIST
JRST LEAV ;RETURN IF NULL
JSP B,INSET ;INITIALIZE NEW SET
; GET A FREE FOR LAST,FIRST NODE
MOVEI PNT,(FP)
SKIPN FP,(FP) ; FOR NEXT TIME
PUSHJ P,FP1DON ; GET SOME MORE IF HAVE RUN OUT
;LEFT HALF WILL CONTAIN ADDR. LAST NODE IN SET.
SETZM (PNT)
;AN IMPORTANT THING TO REMEMBER IN THIS AND ALL OTHER SET-LIST BUILDING
;CODE IS THAT INSET SETS AC 0 TO 0.
LPOUTR: HRRZ A,(A) ;POINT TO NEXT NODE IN LIST
JUMPE A,LTHRU ;IF THROUGH THEN EXIT LOOP
HLRZ D,(A) ;GET ITEM
MOVEI C,(FPD) ;REMEMBER WHO POINTED TO US
HRRZ B,(C) ;ADDR FIRST CANDIDATE
LPINNR: HLRZ PNT,(B) ;GET ITEM FROM SET
CAIG D,(PNT) ;SHOULD WE CONTINUE DOWN CDR
JRST FNDITM ;NO
JUMPE B,FNDITM ;FOR FIRST TIME
MOVEI C,(B) ;YES
HRRZ B,(B) ;NEXT NODE
JRST LPINNR ;LOOP
;NOTICE ABOVE THAT NO EXPLICIT TEST WAS MADE TO DETERMINE IF WE
;HAD EXHAUSTED THE SET. THAT IS TAKEN CARE OF BY THE FACT AC 0 CONTAINS 0
FNDITM: CAIN D,(PNT) ;ALREADY THERE?
JRST LPOUTR ;YES
MOVEI PNT,(FP) ;GET A FREE FOR THIS NEW NODE
SKIPN FP,(FP) ;FOR NEXT TIME
PUSHJ P,FP1DON ;IF OUT, GET SOME MORE
HRRM B,(PNT) ;LINK TO NEXT NODE
HRLM D,(PNT) ;ITEM
HRRM PNT,(C) ;LINK IN FORMER NODE
SOS LPSA ;COUNT OF NUMBER OF ITEMS IN SET
JUMPN B,LPOUTR ;IF NOT LAST NODE IN CHAIN CONTINUE
HRLM PNT,(FPD) ;RECORD NEW LAST NODE
JRST LPOUTR ;LOOP
LTHRU: HRRM FP,FP1(TABL) ;REPLACE FREE LIST POINTER
PUSH P,FPD ;RESULTANT SET TO BE RETURNED
HRLM LPSA,(P) ;STORE COUNT
PUSHJ P,RECL1 ;RECLAIM LIST IF NECESSARY
POP P,-1(P) ;ADJUST STACK
JRST LEAV ;RETURN
DSCR RPLAC
<list_variable> [N] ← <item>
TAC1 POINTS TO LIST_VARIABLE
N IS IN -1(P)
ITEM IN -2(P)
CALLED WITH PUSHJ P,
⊗
RPLAC:
MOVE A,-2(P) ;ITEM
; SKIPN A,-2(P) ;ITEM ;ALLOW UNBOUND DCS 12-12
; ERR <REPLACE WITH UNBOUND ITEM>,1 ; (72)
GLOB<
JSP B,GQSET ;IN CASE GLOBAL SET
>;GLOB
SKIPG B,-1(P) ;N≤0?
ERR <REPLACE - INDEX ≤ 0>
POP P,-1(P) ;MAKE STACK LOOK LIKE CALL
;TO PUT IN
GLOB<
SKIPN FP,FP1(TABL) ;ANY FREE`S YET
PUSHJ P,FP1DON ;NO GET SOME
HRRZS FP
>;GLOB
NOGLOB<
HRRZ FP,FP1(TABL)
>;NOGLOB
HLRE C,(TAC1)
CAMG B,C ;INDEX HIGH?
JRST RPLAC1 ;NORMAL REPLACE
ADDI C,1 ;LENGTH + 1
CAME B,C
ERR <REPLACE - INDEX TOO HIGH>
NLAST: CAIN B,1 ;NEW LIST?
JRST INS1 ;YES
MOVEI PNT,(FP)
HRRZ C,(TAC1)
HLRZ C,(C)
SETZ B, ;END OF LIST?
JRST INSRT ;LET PUT HANDLE IT
RPLAC1: HRRZ D,(TAC1)
LPRPLAC: HRRZ D,(D) ;DOWN LIST
SOJG B,LPRPLAC ;LOOP
HRLM A,(D) ;REPLACE ITEM
JRST RETQ ;RETURN
DSCR TYPEX-to determine the type of an item
CALLING SEQUENCE:
PUSH P,[ITEM#]
PUSHJ P,TYPEX
RETURNS WITH THE STACK APPROPRIATELY DECREMENTED
AND RIGHT HALF OF AC 1 CONTAINING TYPE CODE.
LEFT HALF OF AC 1 CONTAINS ADDRESS OF DATUM ENTRY IF ANY.
TYPE CODES ARE:
0 - item not allocated or ANY
1 - untyped
2 - bracketed triple
3 - string
4 - real
5 - integer
6 - set
7 - list
10 - procedure item
11 - process item
12 - event item
13 - context item
20 - string array
21 - real array
22 - integer array
23 - set array
24 - list array
30 - context array
31 - invalid code
⊗
HERE(TYPEX) ;CALLED WITH PUSHJ FROM USER
PUSH P,TABL ;SAVE AC
PUSH P,B ;SAVE AN AC
SKIPN A,-3(P) ;ITEM #
JRST NTALLOC ;ANY IS NOT CONSIDERED ALLOCATED
MOVE TABL,GOGTAB ;INITIALIZE TO LOCAL MODE
GLOB<
CAIGE A,GBRK ;GLOBAL ITEM?
JRST LCLTYP ;LOCAL
MOVEI TABL,GLUSER ;FOR GLOBAL
CAMGE A,ITMTOP(TABL) ;ALLOCATED?
JRST NTALLOC ;NO
JRST WASALLOC ;YES.
>;GLOB
LCLTYP: CAMLE A,ITMTOP(TABL) ;ALLOCATED?
JRST NTALLOC ;NO.
JUMPLE A,NTALLOC ;INVALID ITEM #?
WASALLOC: MOVEI B,(A) ;COPY ITEM #
ADD A,INFOTAB(TABL) ;ADDRESS INFOTAB ENTRY
ADD B,DATAB(TABL) ;ADDRESS DATAB ENTRY
LDB A,[POINT 6,(A),35] ;GET TYPE CODE
CAILE A,INVTYP ;VALID TYPE
NTVALID: MOVEI A,INVTYP ;INVALID CODE
HRL A,B
POP P,B ;RESTORE AC
POP P,TABL ;RESTORE AC
SUB P,[XWD 2,2]
JRST @2(P) ;RETURN
NTALLOC: SETZ A, ;NOT ALLOCATED TYPE CODE
JRST NTVALID+1 ;RETURN
DSCR TYPEIT -same as TYPEX except does not return datum address in left
half ⊗
HERE(TYPEIT) ;ENTRY POINT
PUSH P,-1(P) ;ITEM NUMBER
PUSHJ P,TYPEX ;GET TYPE
HRRZS A ;ZERO DATUM ADDRESS
SUB P,X22
JRST @2(P) ;RETURN
MOVE FLAG,USER; DUMMY
DSCR REMX -- REMOVE <list_variable> <index>
list_variable pointed to by TAC1
INDEX IN -1(P)
CALLED WITH PUSHJ P,
⊗
REMX:
GLOB<
JSP B,GQSET ;FOR GLOBAL SETS
>;GLOB
JSP B,INSET ;FREE LIST POINTERS ETC.
SKIPG A,-1(P) ;INDEX > 0
ERR <REMOVE - INDEX ≤ 0>
HLRE D,(TAC1) ;LENGTH OF LIST
CAMLE A,D ;INDEX > LENGTH?
ERR <REMOVE - INDEX GTR LENGTH>
MOVE B,(TAC1)
LPREMX: MOVE C,B ;REMEMBER PRECEDING NODE
HRRZ B,(B) ;DOWN-LIST
SOJG A,LPREMX ;COUNT-DOWN
JRST ENREMX ;REST OF CODE WITHIN REMOVE
DSCR REMALL
REMOVE ALL <item> FROM <list_variable>
TAC1 POINTS TO LIST-VARIABLE
ITEM IN -1(P)
CALLED WITH PUSHJ P,
⊗
REMALL:
GLOB<
JSP B,GQSET ;FOR GLOBAL SETS
>;GLOB
JSP B,INSET ;INITIALIZE AC`S FOR LIST CREATION
HRRZ A,-1(P) ;ITEM
MOVE B,(TAC1)
LOPRA1: MOVE C,B ;ADDR PRECEDING NODE
HRRZ B,(B) ;NEXT IN LIST
JUMPE B,RETQ ;NO MORE
HLRZ D,(B) ;ITEM
CAIE D,(A) ;ONE TO BE REMOVED?
JRST LOPRA1 ;NO.
HRRZ D,(B) ;NEXT LINK
CAMN C,(TAC1) ;FIRST ELEMENT?
JRST RAFIRST ;YES.
RACMN: HRRM D,(C) ;DELETE ITEM
HRRM FP,(B) ;ONTO FREE LIST
MOVEI FP,(B) ;NEW HEAD OF FREE LIST
MOVSI B,-1 ;TO DECREMENT LENGTH COUNT
ADDM B,(TAC1) ;DEC COUNT
MOVE B,C ;WILL CONTINUE DOWN LIST
JUMPN D,LOPRA1 ;GO.
MOVE D,(TAC1) ;END OF LIST
HRLM C,(D) ;NEW END OF LIST
JRST RETQ ;RETURN
RAFIRST: JUMPN D,RACMN ;IF LIST NOT NOW NULL BRANCH
JRST ENZERO ;NULL LIST. LET REMOVE HANDLE IT
DSCR LISTX
RETURNS THE INDEX OF THE N TH OCCURRENCE OF ITEM WITHIN
THE LIST OR 0 IF THERE ARE NOT AT LEAST N OCCURRENCES OF
THE ITEM WITHIN THE LIST.
LIST IN -3(P)
ITEM IN -2(P)
N IN -1(P)
CALLED WITH PUSHJ DIRECTLY FROM USER.
⊗
HERE(LISTX)
MOVE D,-1(P) ;N
MOVE B,-2(P) ;ITEM
MOVE C,-3(P) ;LIST
SETZB 0,A ;ZERO AC 0 AND A
LPLSTX: HRRZ C,(C) ;GO DOWN LIST
JUMPE C,ZRETRN ;NOT N DIFFERENT OCCURENCES?
ADDI A,1 ;KEEP TRACK OF INDEX
HLRZ LPSA,(C) ;ITEM
CAIE B,(LPSA) ;ONE WE`RE LOOKING FOR?
JRST LPLSTX ;NO
SOJG D,LPLSTX ;N TH OCCURRENCE?
SKIPA
ZRETRN: SETZ A, ;CLEAR INDEX
EXCH A,-3(P) ;SWAP RESULT AND LIST.
MOVEM A,-1(P) ;PREPARE FOR RECL1
PUSHJ P,RECL1 ;RECLAIM LIST IF NECESSARY
SUB P,X33 ;DEC. STACK
POP P,A ;RESULT
JRST @4(P)
DSCR PUTXA,PUTXB
PUT ITEM IN LIST AFTER(BEFORE) INDEX;
ITEM IN -2(P)
ITEM IN -1(P)
INDEX IN -1(P)
CALLED WITH PUSHJ P,
⊗
PUTXA: MOVE D,-1(P) ;INDEX
AOSA D ;WILL USE PUTXB ROUTINE
PUTXB: MOVE D,-1(P) ;INDEX
MOVE A,-2(P) ;ITEM
; SKIPN A,-2(P) ;ITEM ;ALLOW UNBOUND DCS 12-12-72
; ERR <PUT WITH UNBOUND ITEM>,1
JSP B,INSET ;INITIALIZE FREE STORAGE PNTRS
POP P,-1(P) ;MAKE IT LOOK LIKE CALL TO PUT
JUMPLE D,ERRPUT ;INDEX ≤0 ?
HLRE C,(TAC1) ;LENGTH OF LIST
CAMLE D,C ;INDEX ≤ LENGTH
JRST PTLAST ;NO
HRRZ B,(TAC1) ;NEW LAST OR ERROR
LPPUTX: MOVE C,B
HRRZ B,(B) ;DOWN THE LIST
SOJG D,LPPUTX ;LOOP
JRST INSRT ;
PTLAST: ADDI C,1 ;NEW LAST ELEMENT?
CAME D,C
ERRPUT: ERR <PUT- BAD INDEX>
MOVE B,D ;PREPARE TO JUMP
JRST NLAST ;USE PUTAFTER ROUTINE
DSCR LSTMAK
FOR MAKING UP LISTS OF ITEMS
CALL IS WITH ITEM IN -1(P)
LIST STAYS IN -2(P)
⊗
LSTMAK:
MOVE B,-1(P) ;ITEM
; SKIPN B,-1(P) ;ITEM ;ALLOW UNBOUND IN LIST
; ERR <MAKING LIST WITH UNBOUND ITEM>,1 ;DCS 12-12-72
TLNE FLAG,(BOUND!BINDING)⊗ATTPOS
PUSHJ P,BSATIS ;GET SATISFIER
MOVEI TAC1,-2(P) ;ADDRESS OF SET
PUSH P,B ;SAVE
PUSH P,[0] ;WILL USE PUTA
HLRE B,(TAC1) ;COUNT
MOVMS B ;MAKE POSITIVE
HRLM B,(TAC1) ;STORE IN LIST DESCRIPTOR
PUSHJ P,PUTAFT ;INSERT ITEM INTO LIST AT TAIL
HLRE A,(TAC1) ;GET COUNT AGAIN
MOVNS A ;MAKE NEGATIVE
HRLM A,(TAC1) ;MAKE A TEMP
SUB P,X22
JRST @2(P) ;RETURN
DSCR ARRRCL
TO RECLAIM AN ARRAY OF LISTS OR SETS
ONLY RECLAIMS LIST SPACE, NOT ARRAY SPACE
ARRAY ADDR IN -1(P)
ROUTINE CALLED WITH PUSHJ
⊗
HERE(ARRRCL) ;RECLAIM AN ARRAY OF LISTS
PUSHJ P,FSAV ;SAVE AC'S
MOVE B,-1(P) ;ADDRESS OF ARRAY
HRRZ C,-1(B) ;NUMBER OF ELEMENTS IN ARRAY
ARLOOP: MOVEI TAC1,(B) ;ADDRESS OF LIST
SKIPGE A,(TAC1) ;TEST IF TEMPORARY
ERR <ARRAY TEMP SET -CONFUSION>
JUMPE A,INCBC ;IF NULL, NO NEED TO RECLAIM
PUSH P,B ;SAVE AC
PUSH P,C ;SAVE AC
PUSHJ P,RECQQ ;RECLAIM SET
POP P,C ;RESTORE
POP P,B ;RESTORE
INCBC: ADDI B,1 ;TO NEXT ELEMENT ADDRESS
SOJG C,ARLOOP ;MORE?
PUSHJ P,FREST ;RESTORE CALLERS AC`S
SUB P,X22 ;ADJUST STACK
JRST @2(P) ;RETURN
DSCR INITTP - INITIALIZE ITEM TYPE.
ITEM IS IN -2(P)
TYPE IS IN -1(P)
CALLED WITH PUSHJ P,
⊗
INITTP:
MOVE A,-2(P)
ADD A,INFOTAB(TABL) ;INFOTAB ENTRY ADDRESS
MOVE B,-1(P) ;TYPE
HRRM B,(A) ;STORE CODE
MOVE A,-2(P) ; WILL RETURN ORIGINAL ITEM
SUB P,X33 ;DEC STACK
JRST @3(P) ;RETURN
DSCR INTNAM,CVSI,CVIS,DEL.PNAME,NEW.PNAME ⊗
; PRINT NAME HANDLING FOR THE WORLD.
; FIRST THE ROUTINE TO HASH THINGS UP, THEN
; THE RETRIEVAL ROUTINES.
INTNAM: ;INITIALIZE DECLARED ITEM PNAMES
;;# # DCS 5-3-72 ≤0 ⊃ NO PNAMES
SKIPG (A) ;ANY TO BE INITED?
;;# # DCS
POPJ P, ;NO.
PUSH P,(A) ;NUMBER OF ITEMS IN LIST
ADDI A,1
PUSH P,A ;SAVE ADDRESS OF CURRENT ITEM.
INT1: MOVE A,@(P) ;XWD ITEM NUMBER,, ADDR. STRING DESCRIPTOR
PUSH SP,(A)
PUSH SP,1(A) ;STRING IS THERE.
HLRZS A
PUSH P,A
PUSHJ P,ENTR ;PUT IT IN.....(NEW.PNAME)
AOS (P) ;INDEX THE ADDRESS.
SOSE -1(P) ;ITEM COUNT.
JRST INT1
SUB P,X22
INT4: POPJ P, ;RETURN
INITNM: ;INITIALIZE HASH TABLE
LPCOR (PHASLN) ;ITEM AND STRING HASH TABLE
HRRM B,HASHP(USER)
POPJ P, ;RETURN
; LEFT HALF OF HASH TABLE IS FOR ITEMS
; RIGHT HALF OF HASH TABLE IS FOR STRINGS
IFE ALWAYS, <
EXTERNAL OUTSTR
>
HERE(NEW.PNAME) ;
ENTR: ;ENTRY POINT FOR INTNAME
MOVE USER,GOGTAB
SKIPN HASMSK(USER) ;LEAP INITED?
PUSHJ P,LPINI ;NO, GO INITIALIZE LEAP
MOVE A,HASHP(USER) ;SEE IF PRINTNAMES INITIALIZED
TRNN A,-1 ;HASH TABLE ALLOCATED
PUSHJ P,INITNM ;NO, GO DO IT.
;IF ITEM NOT ALLOCATED NO GOOD
NOGLOB <
SKIPE C,-1(P) ;THE ITEM
LDB C,INFTB ;GET THE TYPE
>;NOGLOB
GLOB <
SKIPN C,-1(P)
JRST PHAVT ;HAV ITEM TYPE
CAIGE C,GBRK ;A GLOBAL?
JRST [LDB C,INFTB
JRST .+2]
LDB C,GINFTB
PHAVT:
>;GLOB
SKIPN C
ERR <ATTEMPT TO GIVE UNALLOCATED ITEM A PNAME>,1
;SEE IF ITEM ALREADY HAS PNAME
PUSH P,[0] ;WILL SERVE AS FLAG PARAM TO CVIS
PUSH P,-2(P) ;ITEM
MOVEI TAC1,-1(P) ;ADDR. FLAG
PUSH P,TAC1 ;FLAG PARM.
PUSHJ P,CVIS ;ALREADY HAVE NAME
SUB SP,X22 ;REMOVE STRING RETURNED BY CVIS
SKIPN (P) ;FLAG TRUE?
JRST [ADD SP,X22 ;RESTORE STRING RETURNED BY CVIS
PUSH SP,-3(SP) ;OUR STRING
PUSH SP,-3(SP)
PUSH SP,-3(SP) ;STRING RETURNED BY CVIS
PUSH SP,-3(SP)
PUSHJ P,EQU ;STRINGS EQUAL?
MOVE USER,GOGTAB;SINCE EQU DESTROYS
JUMPN A,RTRNEW ;IF EQUAL THEN WE MUST RETURN
PRINT <
WARNING ITEM >
PUSHJ P,OUTSTR ;PRINT IT
PRINT < RENAMED TO >
PUSH SP,-1(SP)
PUSH SP,-1(SP)
PUSHJ P,OUTSTR
TERPRI
PUSH P,-2(P) ;ITEM NUMBER(FLAG STILL ON STACK)
PUSHJ P,DEL.PNAME ;REMOVE OLD PNAME
JRST .+1]
;NOW SEE IF STRING ALREADY EXISTS.
PUSH SP,-1(SP) ;COPY STRING
PUSH SP,-1(SP)
MOVEI TAC1,(P) ;ADDRESS OF "FLAG"
PUSH P,TAC1 ;PARAM TO CVSI
PUSHJ P,CVSI
MOVE USER,GOGTAB ;CVSI WILL DESTROY
SUB P,X11 ;REMOVE "FLAG"
SKIPN 1(P) ;SKIP IF NOT ALREADY THERE
JRST [CAMN A,-1(P) ;SAME ITEM?
JRST [ SUB P,X22
SUB SP,X22
JRST @2(P)]
PRINT <ERROR - >
PUSHJ P,OUTSTR ;TYPE PRINTNAME
ERR < USED AS PNAME FOR TWO DIFFERENT ITEMS>
]
PUSHJ P,SDESCR ;GET A FREE STRING DESCRIPTOR
POP P,C ;ADDR. DESCRIPTOR
POP SP,(C) ;STRING
POP SP,-1(C)
SKIPN FP,FP2(USER) ;FOR A TWO-WORD FREE
PUSHJ P,FP2DON ;IF NONE YET GO GET SOME
MOVEI D,(FP) ;OUR NEW FREE
SKIPN FP,(FP) ;FOR NEXT TIME
PUSHJ P,FP2DON ;GET SOME MORE IF NEEDED
MOVEM FP,FP2(USER) ;CDR FREE LIST
HRLM C,1(D) ;STRING
MOVE A,-1(P) ;ITEM
HRLM A,(D) ;STORE IT
ANDI A,PHASLN-1 ;ITEM HASH
ADD A,HASHP(USER) ;TABLE LOC.
HLR C,(A) ;OLD CLASH LIST
HRRM C,(D) ;ADD NEW ELEM.
HRLM D,(A) ;UPDATE CLASH LIST
;STRING HASH
HRRZ C,1(SP) ;STRING LENGTH
SKIPN C ;TEST IF NULL STRING
JRST [ERR <ERROR - NULL PNAME>,1
SUB P,X22
JRST @2(P)]
MOVE B,2(SP) ;BYTE POINTER
ILDB A,B ;FIRST CHARACTER
ILDB B,B ;SECOND CHARACTER IF ANY
LSH A,3 ;HIGH ORDER BIT CARRIES NO INFO
CAIE C,1 ;LENGTH= 1?
XORI A,(B)
ANDI A,PHASLN-1 ;TABLE INDEX
; THIS HASH REALLY COULD STAND SOME IMPROVEMENT.
ADD A,HASHP(USER)
HRR C,(A)
HRRM C,1(D)
HRRM D,(A)
SUB P,X22
JRST @2(P)
RTRNEW: SUB SP,[XWD 4,4]
SUB P,X33
JRST @2(P)
HERE(DEL.PNAME) ;DELETE PNAME IF ANY
MOVE USER,GOGTAB
SKIPN HASMSK(USER) ;LEAP INITIALIZED?
PUSHJ P,LPINI ;GO DO IT
HRRZ A,HASHP(USER) ;PNAMES YET?
JUMPE A,EXDELP ;NO. SIMPLY EXIT
MOVE A,-1(P) ;ITEM NUMBER
ANDI A,PHASLN-1 ;HASH HA HA
ADD A,HASHP(USER) ;HASH POSITION
HRROS (P) ;FLAG INDICATES FIRST IN CONFLICT LIST
MOVEI D,(A) ;ADDRESS THIS BUCKET
HLRZ A,(A)
LPDELP: SKIPN A ;END OF LIST?
JRST [SUB P,X22
HRRZ A,2(P)
JRST (A)] ;RETURN, NO SUCH PNAME
HLRZ B,(A) ;ITEM NUMBER
CAMN B,-1(P) ;ONE WE'RE LOOKING FOR?
JRST DELFND ;YES
MOVEI D,(A)
HRRZS (P)
HRRZ A,(A) ;CDR CONFLICT LIST
JRST LPDELP
DELFND: MOVE C,(A) ;NEXT LINK IN CONFLICT LIST
SKIPG (P) ;NOT FIRST IN CONFLICT LIST?
JRST [HRRZS (P)
HRLM C,(D)
JRST .+2]
HRRM C,(D) ;DELETE NODE FROM LIST
HLRZ C,1(A) ;ADDRESS STRING DESC.
PUSH SP,-1(C) ;SAVE STRING SO CAN DELETE FROM
;STRING HASH TABLE
PUSH SP,(C)
SETZM -1(C) ;SO GARB. COLLECT. WILL IGNORE
HLRZ D,HASHP(USER) ;FREE LIST
HRRM D,(C) ;LINK IT ON
HRLM C,HASHP(USER) ;SAVE UPDATED FREE LIST
ILDB B,(SP) ;FIRST CHAR.
ILDB C,(SP) ;SECOND CHAR
HRRZ D,-1(SP) ;STRING LENGTH
LSH B,3
CAIE D,1
XORI B,(C)
ANDI B,PHASLN-1 ;TABLE INDEX
ADD B,HASHP(USER) ;STRING HASH TABLE POSITION
MOVEI D,(B)
HRRZ B,(B) ;FIRST IN CONFLICT LIST
LPSTRD: SKIPN B
ERR <DRYROT- PNAMES DELETE>
CAIN B,(A) ;ONE WE'RE LOOKING FOR
JRST FNDSBK ;FOUND STRING BUCKET
MOVEI D,1(B)
HRRZ B,1(B) ;CDR CONFLICT LIST
JRST LPSTRD
FNDSBK: HRRZ B,1(B) ;CDR OF CONFLICT LIST
HRRM B,(D) ;PUT IT DOWN
MOVE FP,FP2(USER)
HRRM FP,(A)
MOVE A,FP2(USER)
SUB SP,X22
EXDELP: SUB P,X22
JRST @2(P) ;RETURN
HERE(CVSI) ;STRING TO ITEM
MOVE USER,GOGTAB
SKIPN HASMSK(USER) ;LEAP INITED?
PUSHJ P,LPINI ;GO DO IT
HRRZ A,HASHP(USER) ;PNAMES INITED?
JUMPE A,CVSNO ;CAN'T SUCCEED
MOVE B,(SP) ;BYTE POINTER
ILDB A,B
ILDB B,B
HRRZ C,-1(SP) ;STRING LENGTH
LSH A,3
CAIE C,1
XORI A,(B)
ANDI A,PHASLN-1 ;OUR HASH
ADD A,HASHP(USER)
HRRZ B,(A) ;FIRST IN CONFLICT LIST
LPCVSI: SKIPN B ;END OF LIST?
JRST CVSNO ;STRING NOT FOUND
HLRO C,1(B) ;STRING ADDRESS
PUSH SP,-1(SP)
PUSH SP,-1(SP)
PUSH SP,-1(C)
PUSH SP,(C)
PUSH P,B ;IN CASE EQU DESTROYS
PUSHJ P,EQU ;STRINGS EQUAL?
MOVE USER,GOGTAB
POP P,B
JUMPN A,CVSYES ;FOUND RIGHT STRING
HRRZ B,1(B) ;NO. TRY AGAIN
JRST LPCVSI
CVSYES: SETZM @-1(P) ;FLAG←FALSE
HLRZ A,(B) ;ITEM NUMBER
CAIA
CVSNO: SETOM @-1(P)
SUB SP,X22
SUB P,X22
JRST @2(P)
HERE(CVIS) ;ITEM TO STRING
MOVE USER,GOGTAB
SKIPN HASMSK(USER) ;LEAP INITED?
PUSHJ P,LPINI ;NO GO DO IT
HRRZ A,HASHP(USER) ;ANY PNAMES?
JUMPE A,CVINO ;IF NONE, CAN'T SUCCEED
MOVE A,-2(P) ;ITEM NUMBER
ANDI A,PHASLN-1
ADD A,HASHP(USER)
HLRZ B,(A)
LPCVIS: SKIPN B
JRST CVINO ;NO SUCH PNAME
HLRZ A,(B) ;ITEM NUMBER
CAMN A,-2(P) ;SAME AS OURS?
JRST CVIYES ;SUCCESS
HRRZ B,(B) ;CDR OF CONFLICT LIST
JRST LPCVIS ;TRY AGAIN
CVIYES: HLRZ C,1(B) ;STRING ADDR
PUSH SP,-1(C) ;RETURN ON STRING STACK
PUSH SP,(C)
SETZM @-1(P) ;FLAG←FALSE
JRST CVIRET
CVINO: ADD SP,X22 ;RETURN GARBAGE STRING
;;#HP#↓ 6-8-72 DCS GARBAGE STRING MUST BE GARBAGE COLLECTABLE!
SETZM -1(SP) ;CONSTANT, NULL STRING -- HARMLESS
SETOM @-1(P) ;FLAG←TRUE
CVIRET: SUB P,X33
JRST @3(P)
DSCR MATCHING PROCEDURE ROUTINES, CALMP,RESMP,SUCFA1;
⊗
;CALMP ON STACK IS PLACE FOR ITEM,PROCEDURE CALL WITH PDA AT VERY
;TOP OF STACK. ROUTINE IS JRSTED TO
SOPTS ←← 11 ;SPROUT OPTIONS,SUSPEND HIM LET ME CONTINUE
ROPTS ←← 0 ;RESUME OPTIONS
CALMP: ;SPROUT MATCHING PROCEDURE
GLOB <
NOSEC ;NOT "ENTERED" INSIDE FOREACH'S
>;GLOB
PUSHJ P,FRPOP ;POP SATIS INTO CORE, ALSO LOADS FRTAB
MOVE FPD,FPDP(FRTAB) ;FOREACH PUSH DOWN LIST
ADD FPD,[XWD LENFPD,LENFPD] ;MAKE AN ENTRY ON PDL
SKIPL FPD
PDLOF
MOVEM FPD,FPDP(FRTAB) ;REPLACE PDL POINTER
HRRI FLAG,CALINDX-SEROUT ;SEROUT # FOR RESUME MP
MOVEM FLAG,-1(FPD) ;PUT DOWN ROUTINE NAME
MOVE D,UUO1(USER) ;PICKUP RETURN ADDRRESS
MOVEM D,(FPD) ;PUT IT DOWN
SETOM -TT1(FPD) ;BE CONSISTENT WITH OTHERS
SETZM -T2(FPD)
PUSHJ P,NEW ;GET AN ITEM FOR PROCESS
POP P,D ;THE ITEM
MOVEM D,-ATTP(FPD) ;SAVE IN FPD ENTRY
MOVE C,(P) ;PICK-UP PDA
HLRZ LPSA,PD.NPW(C) ;NUMBER OF STRING ENTRIES
HRRZ B,PD.NPW(C) ;NON STRING ENTRIES
ADD LPSA,B ;DISPLACEMENT
MOVNS LPSA
ADDI LPSA,(P) ;ADDR OF ITEM SLOT
MOVEM D,(LPSA) ;PUT ITEM DOWN
PUSH P,[SOPTS] ;THE OPTIONS FOR SPROUT
HRRZI LPSA,-MASK(FPD) ;THE"KILL-SET"
SETZM -MASK(FPD) ;MAKE NIL
PUSH P,LPSA
PUSHJ P,SPROUT ;SPROUT IT
MOVE USER,GOGTAB
MOVE FRTAB,FRLOC(USER)
SKIPE A,RUNNER
MOVE FRTAB,CURSCB(A)
MOVE FPD,FPDP(FRTAB)
JRST GO ;RESUME IT
RESMP: ;RESUME THE MATCHING PROCEDURE
MOVEM FPD,FPDP(FRTAB) ;SAVE PDP
PUSH P,-ATTP(FPD) ;PROCESS_ITEM
PUSH P,[0] ;NULL PARAM
PUSH P,[ROPTS] ;RESUME OPTIONS
PUSHJ P,RESUME ;RESUME IT
MOVE USER,GOGTAB
MOVE FRTAB,FRLOC(USER)
SKIPE D,RUNNER
MOVE FRTAB,CURSCB(D)
MOVE FPD,FPDP(FRTAB)
JUMPE 1,MPFAIL ;WAS IT SUCCESS
PUSHJ P,CORPOP ;GET CORE INTO SATIS TABLE
AOS (P) ;SUCCESS, SKIP RETURN
POPJ P, ;YES
MPFAIL: PUSH P,-ATTP(FPD) ;THE ITEM
MOVEI D,MPDEL ;PREPARE FOR CALL TO DELETE
MOVEM D,UUO1(USER)
GLOB <
MOVEI TABL,(USER)
>;GLOB
JRST DELETE
MPDEL:
GLOB<
NOSEC
>;GLOB
MOVE USER,GOGTAB
MOVE FRTAB,FRLOC(USER) ;SINCE DELETE DESTROYED
SKIPE A,RUNNER
MOVE FRTAB,CURSCB(A)
MOVE FPD,FPDP(FRTAB)
POPJ P, ;REPORT FAILURE
DSCR .SUCCE,.FAIL
SUCCEED OR FAIL
WE DO A SKIP RETURN IF A PROCESS,OTHERWISE WE SIMPLY
RETURN, WHICH WILL JUMP TO END OF MATCHING PROCEDURE AND
GIVE A NORMAL RETURN
PDA OF MATCHING PROCEDURE ON TOP OF STACK
⊗
INTERNAL .FAIL,.SUCCE
SFOPTS ←← 0 ;SUCCEED FAIL OPTIONS
HERE(.FAIL)
TDZA A,A
HERE(.SUCCE)
SETOM A
POP P,TEMP ;THE RETURN ADDRESS
EXCH TEMP,(P) ;THE PDA
MOVE D,RF ;CURRENT DISPLAY
LPSFA: HLRZ C,1(D) ;PDA THIS DISPLAY LEVEL
MOVE D,(D) ;BACK ONE LEVEL
CAIE C,(TEMP) ;THIS THE ONE?
JRST LPSFA ;NO.
HLRZ C,1(D) ;PDA OF "FATHER"
CAIE C,SPRPDA ;SPROUTER?
POPJ P, ;NO.
;PUSH ITEM NUMBER OF "SPROUTER"
MOVE D,RUNNER ;BASE OF PROCESS STACK
PUSH P,DADDY(D) ;WHO SPROUTED ME
PUSH P,1 ;VAL TO BE RETURNED
PUSH P,[SFOPTS] ;OPTIONS
PUSHJ P,RESUME ;RESUME
AOS (P)
POPJ P, ;SKIP RETURN
NOGLOB <
BEND LEAP
>;NOGLOB
IFE ALWAYS,<
END
>